luna.el

   1 ;;; luna.el --- tiny OOP system kernel
   2
   3 ;; Copyright (C) 1999,2000,2002 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: OOP
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29
  30 ;;; @ class
  31 ;;;
  32
  33 (defmacro luna-find-class (name)
  34   "Return a luna-class that has NAME."
  35   `(get ,name 'luna-class))
  36
  37 ;; Give NAME (symbol) the luna-class CLASS.
  38 (defmacro luna-set-class (name class)
  39   `(put ,name 'luna-class ,class))
  40
  41 ;; Return the obarray of luna-class CLASS.
  42 (defmacro luna-class-obarray (class)
  43   `(aref ,class 1))
  44
  45 ;; Return the parents of luna-class CLASS.
  46 (defmacro luna-class-parents (class)
  47   `(aref ,class 2))
  48
  49 ;; Return the number of slots of luna-class CLASS.
  50 (defmacro luna-class-number-of-slots (class)
  51   `(aref ,class 3))
  52
  53 (defmacro luna-define-class (class &optional parents slots)
  54   "Define CLASS as a luna-class.
  55 CLASS always inherits the luna-class `standard-object'.
  56
  57 The optional 1st arg PARENTS is a list luna-class names.  These
  58 luna-classes are also inheritted by CLASS.
  59
  60 The optional 2nd arg SLOTS is a list of slots CLASS will have."
  61   `(luna-define-class-function ',class ',(append parents '(standard-object))
  62                                ',slots))
  63
  64
  65 ;; Define CLASS as a luna-class.  PARENTS, if non-nil, is a list of
  66 ;; luna-class names inherited by CLASS.  SLOTS, if non-nil, is a list
  67 ;; of slots belonging to CLASS.
  68
  69 (defun luna-define-class-function (class &optional parents slots)
  70   (let ((oa (make-vector 31 0))
  71         (rest parents)
  72         parent name
  73         (i 2)
  74         b j)
  75     (while rest
  76       (setq parent (pop rest)
  77             b (- i 2))
  78       (mapatoms (lambda (sym)
  79                   (when (setq j (get sym 'luna-slot-index))
  80                     (setq name (symbol-name sym))
  81                     (unless (intern-soft name oa)
  82                       (put (intern name oa) 'luna-slot-index (+ j b))
  83                       (setq i (1+ i)))))
  84                 (luna-class-obarray (luna-find-class parent))))
  85     (setq rest slots)
  86     (while rest
  87       (setq name (symbol-name (pop rest)))
  88       (unless (intern-soft name oa)
  89         (put (intern name oa) 'luna-slot-index i)
  90         (setq i (1+ i))))
  91     (luna-set-class class (vector 'class oa parents i))))
  92
  93
  94 ;; Return a member (slot or method) of CLASS that has name
  95 ;; MEMBER-NAME.
  96
  97 (defun luna-class-find-member (class member-name)
  98   (or (stringp member-name)
  99       (setq member-name (symbol-name member-name)))
 100   (intern-soft member-name (luna-class-obarray class)))
 101
 102
 103 ;; Return a member (slot or method) of CLASS that has name
 104 ;; MEMBER-NAME.  If CLASS doesnt' have such a member, make it in
 105 ;; CLASS.
 106
 107 (defsubst luna-class-find-or-make-member (class member-name)
 108   (or (stringp member-name)
 109       (setq member-name (symbol-name member-name)))
 110   (intern member-name (luna-class-obarray class)))
 111
 112
 113 ;; Return the index number of SLOT-NAME in CLASS.
 114
 115 (defmacro luna-class-slot-index (class slot-name)
 116   `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
 117
 118 (defmacro luna-define-method (name &rest definition)
 119   "Define NAME as a method of a luna class.
 120
 121 Usage of this macro follows:
 122
 123   (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
 124
 125 The optional 1st argument METHOD-QUALIFIER specifies when and how the
 126 method is called.
 127
 128 If it is :before, call the method before calling the parents' methods.
 129
 130 If it is :after, call the method after calling the parents' methods.
 131
 132 If it is :around, call the method only.  The parents' methods can be
 133 executed by calling the function `luna-call-next-method' in BODY.
 134
 135 Otherwize, call the method only, and the parents' methods are never
 136 executed.  In this case, METHOD-QUALIFIER is treated as ARGLIST.
 137
 138 ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a
 139 variable name that should be bound to an entity that receives the
 140 message NAME, CLASS is a class name.  The first argument to the method
 141 is VAR, and the remaining arguments are METHOD-ARGs.
 142
 143 If VAR is nil, arguments to the method are METHOD-ARGs.  This kind of
 144 methods can't be called from generic-function (see
 145 `luna-define-generic').
 146
 147 The optional 4th argument DOCSTRING is the documentation of the
 148 method.  If it is not string, it is treated as BODY.
 149
 150 The optional 5th BODY is the body of the method."
 151   (let ((method-qualifier (pop definition))
 152         args specializer class self)
 153     (if (memq method-qualifier '(:before :after :around))
 154         (setq args (pop definition))
 155       (setq args method-qualifier
 156             method-qualifier nil))
 157     (setq specializer (car args)
 158           class (nth 1 specializer)
 159           self (car specializer))
 160     `(let ((func (lambda ,(if self
 161                               (cons self (cdr args))
 162                             (cdr args))
 163                    ,@definition))
 164            (sym (luna-class-find-or-make-member
 165                  (luna-find-class ',class) ',name))
 166            (cache (get ',name 'luna-method-cache)))
 167        (and cache
 168             (fboundp sym)
 169             (mapatoms
 170              (lambda (s)
 171                (if (memq (symbol-function sym) (symbol-value s))
 172                    (unintern s cache)))
 173              cache))
 174        (fset sym func)
 175        (put sym 'luna-method-qualifier ,method-qualifier))))
 176
 177 (put 'luna-define-method 'lisp-indent-function 'defun)
 178
 179 (def-edebug-spec luna-define-method
 180   (&define name [&optional &or ":before" ":after" ":around"]
 181            ((arg symbolp)
 182             [&rest arg]
 183             [&optional ["&optional" arg &rest arg]]
 184             &optional ["&rest" arg])
 185            def-body))
 186
 187
 188 ;; Return a list of method functions named SERVICE registered in the
 189 ;; parents of CLASS.
 190
 191 (defun luna-class-find-parents-functions (class service)
 192   (let ((parents (luna-class-parents class))
 193         ret)
 194     (while (and parents
 195                 (null
 196                  (setq ret (luna-class-find-functions
 197                             (luna-find-class (pop parents))
 198                             service)))))
 199     ret))
 200
 201 ;; Return a list of method functions named SERVICE registered in CLASS
 202 ;; and the parents..
 203
 204 (defun luna-class-find-functions (class service)
 205   (let ((sym (luna-class-find-member class service)))
 206     (if (fboundp sym)
 207         (cond ((eq (get sym 'luna-method-qualifier) :before)
 208                (cons (symbol-function sym)
 209                      (luna-class-find-parents-functions class service)))
 210               ((eq (get sym 'luna-method-qualifier) :after)
 211                (nconc (luna-class-find-parents-functions class service)
 212                       (list (symbol-function sym))))
 213               ((eq (get sym 'luna-method-qualifier) :around)
 214                (cons sym (luna-class-find-parents-functions class service)))
 215               (t
 216                (list (symbol-function sym))))
 217       (luna-class-find-parents-functions class service))))
 218
 219
 220 ;;; @ instance (entity)
 221 ;;;
 222
 223 (defmacro luna-class-name (entity)
 224   "Return class-name of the ENTITY."
 225   `(aref ,entity 0))
 226
 227 (defmacro luna-set-class-name (entity name)
 228   `(aset ,entity 0 ,name))
 229
 230 (defmacro luna-get-obarray (entity)
 231   `(aref ,entity 1))
 232
 233 (defmacro luna-set-obarray (entity obarray)
 234   `(aset ,entity 1 ,obarray))
 235
 236 (defmacro luna-slot-index (entity slot-name)
 237   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 238                           ,slot-name))
 239
 240 (defsubst luna-slot-value (entity slot)
 241   "Return the value of SLOT of ENTITY."
 242   (aref entity (luna-slot-index entity slot)))
 243
 244 (defsubst luna-set-slot-value (entity slot value)
 245   "Store VALUE into SLOT of ENTITY."
 246   (aset entity (luna-slot-index entity slot) value))
 247
 248 (defmacro luna-find-functions (entity service)
 249   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 250                               ,service))
 251
 252 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 253   "Send MESSAGE to ENTITY, and return the result.
 254 ENTITY is an instance of a luna class, and MESSAGE is a method name of
 255 the luna class.
 256 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 257   (let ((luna-next-methods (luna-find-functions entity message))
 258         luna-current-method
 259         luna-previous-return-value)
 260     (while (and luna-next-methods
 261                 (progn
 262                   (setq luna-current-method (pop luna-next-methods)
 263                         luna-previous-return-value
 264                         (apply luna-current-method
 265                                luna-current-method-arguments))
 266                   (if (symbolp luna-current-method)
 267                       (not (eq (get luna-current-method
 268                                     'luna-method-qualifier) :around))
 269                     t))))
 270     luna-previous-return-value))
 271
 272 (eval-when-compile
 273   (defvar luna-next-methods nil)
 274   (defvar luna-current-method-arguments nil))
 275
 276 (defun luna-call-next-method ()
 277   "Call the next method in the current method function.
 278 A method function that has :around qualifier should call this function
 279 to execute the parents' methods."
 280   (let (luna-current-method
 281         luna-previous-return-value)
 282     (while (and luna-next-methods
 283                 (progn
 284                   (setq luna-current-method (pop luna-next-methods)
 285                         luna-previous-return-value
 286                         (apply luna-current-method
 287                                luna-current-method-arguments))
 288                   (if (symbolp luna-current-method)
 289                       (not (eq (get luna-current-method
 290                                     'luna-method-qualifier) :around))
 291                     t))))
 292     luna-previous-return-value))
 293
 294 (defun luna-make-entity (class &rest init-args)
 295   "Make an entity (instance) of luna-class CLASS and return it.
 296 INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
 297 where SLOTs are slots of CLASS and the VALs are initial values of
 298 the corresponding SLOTs."
 299   (let* ((c (get class 'luna-class))
 300          (v (make-vector (luna-class-number-of-slots c) nil)))
 301     (luna-set-class-name v class)
 302     (luna-set-obarray v (make-vector 7 0))
 303     (apply #'luna-send v 'initialize-instance v init-args)))
 304
 305
 306 ;;; @ interface (generic function)
 307 ;;;
 308
 309 ;; Find a method of ENTITY that handles MESSAGE, and call it with
 310 ;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
 311
 312 (defun luna-apply-generic (entity message &rest luna-current-method-arguments)
 313   (let* ((class (luna-class-name entity))
 314          (cache (get message 'luna-method-cache))
 315          (sym (intern-soft (symbol-name class) cache))
 316          luna-next-methods)
 317     (if sym
 318         (setq luna-next-methods (symbol-value sym))
 319       (setq luna-next-methods
 320             (luna-find-functions entity message))
 321       (set (intern (symbol-name class) cache)
 322            luna-next-methods))
 323     (luna-call-next-method)))
 324
 325
 326 ;; Convert ARGLIST (argument list spec for a method function) to the
 327 ;; actual list of arguments.
 328
 329 (defsubst luna-arglist-to-arguments (arglist)
 330   (let (dest)
 331     (while arglist
 332       (let ((arg (car arglist)))
 333         (or (memq arg '(&optional &rest))
 334             (setq dest (cons arg dest))))
 335       (setq arglist (cdr arglist)))
 336     (nreverse dest)))
 337
 338
 339 (defmacro luna-define-generic (name args &optional doc)
 340   "Define a function NAME that provides a generic interface to the method NAME.
 341 ARGS is the argument list for NAME.  The first element of ARGS is an
 342 entity.
 343
 344 The function handles a message sent to the entity by calling the
 345 method with proper arguments.
 346
 347 The optional 3rd argument DOC is the documentation string for NAME."
 348   (if doc
 349       `(progn
 350          (defun ,(intern (symbol-name name)) ,args
 351            ,doc
 352            (luna-apply-generic ,(car args) ',name
 353                                ,@(luna-arglist-to-arguments args)))
 354          (put ',name 'luna-method-cache (make-vector 31 0)))
 355     `(progn
 356        (defun ,(intern (symbol-name name)) ,args
 357          (luna-apply-generic ,(car args) ',name
 358                              ,@(luna-arglist-to-arguments args)))
 359        (put ',name 'luna-method-cache (make-vector 31 0)))))
 360
 361 (put 'luna-define-generic 'lisp-indent-function 'defun)
 362
 363
 364 ;;; @ accessor
 365 ;;;
 366
 367 (defun luna-define-internal-accessors (class-name)
 368   "Define internal accessors for instances of the luna class CLASS-NAME.
 369
 370 Internal accessors are macros to refer and set a slot value of the
 371 instances.  For instance, if the class has SLOT, macros
 372 CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
 373
 374 CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
 375 the value of SLOT.
 376
 377 CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
 378 and sets SLOT to VALUE."
 379   (let ((entity-class (luna-find-class class-name))
 380         parents parent-class)
 381     (mapatoms
 382      (lambda (slot)
 383        (if (luna-class-slot-index entity-class slot)
 384            (catch 'derived
 385              (setq parents (luna-class-parents entity-class))
 386              (while parents
 387                (setq parent-class (luna-find-class (car parents)))
 388                (if (luna-class-slot-index parent-class slot)
 389                    (throw 'derived nil))
 390                (setq parents (cdr parents)))
 391              (eval
 392               `(progn
 393                  (defmacro ,(intern (format "%s-%s-internal"
 394                                             class-name slot))
 395                    (entity)
 396                    (list 'aref entity
 397                          ,(luna-class-slot-index entity-class
 398                                                  (intern (symbol-name slot)))))
 399                  (defmacro ,(intern (format "%s-set-%s-internal"
 400                                             class-name slot))
 401                    (entity value)
 402                    (list 'aset entity
 403                          ,(luna-class-slot-index
 404                            entity-class (intern (symbol-name slot)))
 405                          value)))))))
 406      (luna-class-obarray entity-class))))
 407
 408
 409 ;;; @ standard object
 410 ;;;
 411
 412 ;; Define super class of all luna classes.
 413 (luna-define-class-function 'standard-object)
 414
 415 (luna-define-method initialize-instance ((entity standard-object)
 416                                          &rest init-args)
 417   "Initialize slots of ENTITY by INIT-ARGS."
 418   (let* ((c (luna-find-class (luna-class-name entity)))
 419          (oa (luna-class-obarray c))
 420          s i)
 421     (while init-args
 422       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 423             i (pop init-args))
 424       (if s
 425           (aset entity (get s 'luna-slot-index) i)))
 426     entity))
 427
 428
 429 ;;; @ end
 430 ;;;
 431
 432 (provide 'luna)
 433
 434 ;; luna.el ends here