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., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, 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        (if cache
 168            (unintern ',class cache))
 169        (fset sym func)
 170        (put sym 'luna-method-qualifier ,method-qualifier))))
 171
 172 (put 'luna-define-method 'lisp-indent-function 'defun)
 173
 174 (def-edebug-spec luna-define-method
 175   (&define name [&optional &or ":before" ":after" ":around"]
 176            ((arg symbolp)
 177             [&rest arg]
 178             [&optional ["&optional" arg &rest arg]]
 179             &optional ["&rest" arg])
 180            def-body))
 181
 182
 183 ;; Return a list of method functions named SERVICE registered in the
 184 ;; parents of CLASS.
 185
 186 (defun luna-class-find-parents-functions (class service)
 187   (let ((parents (luna-class-parents class))
 188         ret)
 189     (while (and parents
 190                 (null
 191                  (setq ret (luna-class-find-functions
 192                             (luna-find-class (pop parents))
 193                             service)))))
 194     ret))
 195
 196 ;; Return a list of method functions named SERVICE registered in CLASS
 197 ;; and the parents..
 198
 199 (defun luna-class-find-functions (class service)
 200   (let ((sym (luna-class-find-member class service)))
 201     (if (fboundp sym)
 202         (cond ((eq (get sym 'luna-method-qualifier) :before)
 203                (cons (symbol-function sym)
 204                      (luna-class-find-parents-functions class service)))
 205               ((eq (get sym 'luna-method-qualifier) :after)
 206                (nconc (luna-class-find-parents-functions class service)
 207                       (list (symbol-function sym))))
 208               ((eq (get sym 'luna-method-qualifier) :around)
 209                (cons sym (luna-class-find-parents-functions class service)))
 210               (t
 211                (list (symbol-function sym))))
 212       (luna-class-find-parents-functions class service))))
 213
 214
 215 ;;; @ instance (entity)
 216 ;;;
 217
 218 (defmacro luna-class-name (entity)
 219   "Return class-name of the ENTITY."
 220   `(aref ,entity 0))
 221
 222 (defmacro luna-set-class-name (entity name)
 223   `(aset ,entity 0 ,name))
 224
 225 (defmacro luna-get-obarray (entity)
 226   `(aref ,entity 1))
 227
 228 (defmacro luna-set-obarray (entity obarray)
 229   `(aset ,entity 1 ,obarray))
 230
 231 (defmacro luna-slot-index (entity slot-name)
 232   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 233                           ,slot-name))
 234
 235 (defsubst luna-slot-value (entity slot)
 236   "Return the value of SLOT of ENTITY."
 237   (aref entity (luna-slot-index entity slot)))
 238
 239 (defsubst luna-set-slot-value (entity slot value)
 240   "Store VALUE into SLOT of ENTITY."
 241   (aset entity (luna-slot-index entity slot) value))
 242
 243 (defmacro luna-find-functions (entity service)
 244   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 245                               ,service))
 246
 247 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 248   "Send MESSAGE to ENTITY, and return the result.
 249 ENTITY is an instance of a luna class, and MESSAGE is a method name of
 250 the luna class.
 251 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 252   (let ((luna-next-methods (luna-find-functions entity message))
 253         luna-current-method
 254         luna-previous-return-value)
 255     (while (and luna-next-methods
 256                 (progn
 257                   (setq luna-current-method (pop luna-next-methods)
 258                         luna-previous-return-value
 259                         (apply luna-current-method
 260                                luna-current-method-arguments))
 261                   (if (symbolp luna-current-method)
 262                       (not (eq (get luna-current-method
 263                                     'luna-method-qualifier) :around))
 264                     t))))
 265     luna-previous-return-value))
 266
 267 (eval-when-compile
 268   (defvar luna-next-methods nil)
 269   (defvar luna-current-method-arguments nil))
 270
 271 (defun luna-call-next-method ()
 272   "Call the next method in the current method function.
 273 A method function that has :around qualifier should call this function
 274 to execute the parents' methods."
 275   (let (luna-current-method
 276         luna-previous-return-value)
 277     (while (and luna-next-methods
 278                 (progn
 279                   (setq luna-current-method (pop luna-next-methods)
 280                         luna-previous-return-value
 281                         (apply luna-current-method
 282                                luna-current-method-arguments))
 283                   (if (symbolp luna-current-method)
 284                       (not (eq (get luna-current-method
 285                                     'luna-method-qualifier) :around))
 286                     t))))
 287     luna-previous-return-value))
 288
 289 (defun luna-make-entity (class &rest init-args)
 290   "Make an entity (instance) of luna-class CLASS and return it.
 291 INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
 292 where SLOTs are slots of CLASS and the VALs are initial values of
 293 the corresponding SLOTs."
 294   (let* ((c (get class 'luna-class))
 295          (v (make-vector (luna-class-number-of-slots c) nil)))
 296     (luna-set-class-name v class)
 297     (luna-set-obarray v (make-vector 7 0))
 298     (apply #'luna-send v 'initialize-instance v init-args)))
 299
 300
 301 ;;; @ interface (generic function)
 302 ;;;
 303
 304 ;; Find a method of ENTITY that handles MESSAGE, and call it with
 305 ;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
 306
 307 (defun luna-apply-generic (entity message &rest luna-current-method-arguments)
 308   (let* ((class (luna-class-name entity))
 309          (cache (get message 'luna-method-cache))
 310          (sym (intern-soft (symbol-name class) cache))
 311          luna-next-methods)
 312     (if sym
 313         (setq luna-next-methods (symbol-value sym))
 314       (setq luna-next-methods
 315             (luna-find-functions entity message))
 316       (set (intern (symbol-name class) cache)
 317            luna-next-methods))
 318     (luna-call-next-method)))
 319
 320
 321 ;; Convert ARGLIST (argument list spec for a method function) to the
 322 ;; actual list of arguments.
 323
 324 (defsubst luna-arglist-to-arguments (arglist)
 325   (let (dest)
 326     (while arglist
 327       (let ((arg (car arglist)))
 328         (or (memq arg '(&optional &rest))
 329             (setq dest (cons arg dest))))
 330       (setq arglist (cdr arglist)))
 331     (nreverse dest)))
 332
 333
 334 (defmacro luna-define-generic (name args &optional doc)
 335   "Define a function NAME that provides a generic interface to the method NAME.
 336 ARGS is the argument list for NAME.  The first element of ARGS is an
 337 entity.
 338
 339 The function handles a message sent to the entity by calling the
 340 method with proper arguments.
 341
 342 The optional 3rd argument DOC is the documentation string for NAME."
 343   (if doc
 344       `(progn
 345          (defun ,(intern (symbol-name name)) ,args
 346            ,doc
 347            (luna-apply-generic ,(car args) ',name
 348                                ,@(luna-arglist-to-arguments args)))
 349          (put ',name 'luna-method-cache (make-vector 31 0)))
 350     `(progn
 351        (defun ,(intern (symbol-name name)) ,args
 352          (luna-apply-generic ,(car args) ',name
 353                              ,@(luna-arglist-to-arguments args)))
 354        (put ',name 'luna-method-cache (make-vector 31 0)))))
 355
 356 (put 'luna-define-generic 'lisp-indent-function 'defun)
 357
 358
 359 ;;; @ accessor
 360 ;;;
 361
 362 (defun luna-define-internal-accessors (class-name)
 363   "Define internal accessors for instances of the luna class CLASS-NAME.
 364
 365 Internal accessors are macros to refer and set a slot value of the
 366 instances.  For instance, if the class has SLOT, macros
 367 CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
 368
 369 CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
 370 the value of SLOT.
 371
 372 CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
 373 and sets SLOT to VALUE."
 374   (let ((entity-class (luna-find-class class-name))
 375         parents parent-class)
 376     (mapatoms
 377      (lambda (slot)
 378        (if (luna-class-slot-index entity-class slot)
 379            (catch 'derived
 380              (setq parents (luna-class-parents entity-class))
 381              (while parents
 382                (setq parent-class (luna-find-class (car parents)))
 383                (if (luna-class-slot-index parent-class slot)
 384                    (throw 'derived nil))
 385                (setq parents (cdr parents)))
 386              (eval
 387               `(progn
 388                  (defmacro ,(intern (format "%s-%s-internal"
 389                                             class-name slot))
 390                    (entity)
 391                    (list 'aref entity
 392                          ,(luna-class-slot-index entity-class
 393                                                  (intern (symbol-name slot)))))
 394                  (defmacro ,(intern (format "%s-set-%s-internal"
 395                                             class-name slot))
 396                    (entity value)
 397                    (list 'aset entity
 398                          ,(luna-class-slot-index
 399                            entity-class (intern (symbol-name slot)))
 400                          value)))))))
 401      (luna-class-obarray entity-class))))
 402
 403
 404 ;;; @ standard object
 405 ;;;
 406
 407 ;; Define super class of all luna classes.
 408 (luna-define-class-function 'standard-object)
 409
 410 (luna-define-method initialize-instance ((entity standard-object)
 411                                          &rest init-args)
 412   "Initialize slots of ENTITY by INIT-ARGS."
 413   (let* ((c (luna-find-class (luna-class-name entity)))
 414          (oa (luna-class-obarray c))
 415          s i)
 416     (while init-args
 417       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 418             i (pop init-args))
 419       (if s
 420           (aset entity (get s 'luna-slot-index) i)))
 421     entity))
 422
 423
 424 ;;; @ end
 425 ;;;
 426
 427 (provide 'luna)
 428
 429 ;; luna.el ends here