luna.el

   1 ;;; luna.el --- tiny OOP system kernel
   2
   3 ;; Copyright (C) 1999,2000 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   (or (intern-soft member-name (luna-class-obarray class))
 101       (let ((parents (luna-class-parents class))
 102             ret)
 103         (while (and parents
 104                     (null
 105                      (setq ret (luna-class-find-member
 106                                 (luna-find-class (pop parents))
 107                                 member-name)))))
 108         ret)))
 109
 110
 111 ;; Return a member (slot or method) of CLASS that has name
 112 ;; MEMBER-NAME.  If CLASS doesnt' have such a member, make it in
 113 ;; CLASS.
 114
 115 (defsubst luna-class-find-or-make-member (class member-name)
 116   (or (stringp member-name)
 117       (setq member-name (symbol-name member-name)))
 118   (intern member-name (luna-class-obarray class)))
 119
 120
 121 ;; Return the index number of SLOT-NAME in CLASS.
 122
 123 (defmacro luna-class-slot-index (class slot-name)
 124   `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
 125
 126 (defmacro luna-define-method (name &rest definition)
 127   "Define NAME as a method of a luna class.
 128
 129 Usage of this macro follows:
 130
 131   (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
 132
 133 The optional 1st argument METHOD-QUALIFIER specifies when and how the
 134 method is called.
 135
 136 If it is :before, call the method before calling the parents' methods.
 137
 138 If it is :after, call the method after calling the parents' methods.
 139
 140 If it is :around, call the method only.  The parents' methods can be
 141 executed by calling the function `luna-call-next-method' in BODY.
 142
 143 Otherwize, call the method only, and the parents' methods are never
 144 executed.  In this case, METHOD-QUALIFIER is treated as ARGLIST.
 145
 146 ARGLIST has the form ((VAR CLASS) METHOD-ARG ...), where VAR is a
 147 variable name that should be bound to an entity that receives the
 148 message NAME, CLASS is a class name.  The first argument to the method
 149 is VAR, and the remaining arguments are METHOD-ARGs.
 150
 151 If VAR is nil, arguments to the method are METHOD-ARGs.  This kind of
 152 methods can't be called from generic-function (see
 153 `luna-define-generic').
 154
 155 The optional 4th argument DOCSTRING is the documentation of the
 156 method.  If it is not string, it is treated as BODY.
 157
 158 The optional 5th BODY is the body of the method."
 159   (let ((method-qualifier (pop definition))
 160         args specializer class self)
 161     (if (memq method-qualifier '(:before :after :around))
 162         (setq args (pop definition))
 163       (setq args method-qualifier
 164             method-qualifier nil))
 165     (setq specializer (car args)
 166           class (nth 1 specializer)
 167           self (car specializer))
 168     `(let ((func (lambda ,(if self
 169                               (cons self (cdr args))
 170                             (cdr args))
 171                    ,@definition))
 172            (sym (luna-class-find-or-make-member
 173                  (luna-find-class ',class) ',name))
 174            (cache (get ',name 'luna-method-cache)))
 175        (if cache
 176            (unintern ',class cache))
 177        (fset sym func)
 178        (put sym 'luna-method-qualifier ,method-qualifier))))
 179
 180 (put 'luna-define-method 'lisp-indent-function 'defun)
 181
 182 (def-edebug-spec luna-define-method
 183   (&define name [&optional &or ":before" ":after" ":around"]
 184            ((arg symbolp)
 185             [&rest arg]
 186             [&optional ["&optional" arg &rest arg]]
 187             &optional ["&rest" arg])
 188            def-body))
 189
 190
 191 ;; Return a list of method functions named SERVICE registered in the
 192 ;; parents of CLASS.
 193
 194 (defun luna-class-find-parents-functions (class service)
 195   (let ((parents (luna-class-parents class))
 196         ret)
 197     (while (and parents
 198                 (null
 199                  (setq ret (luna-class-find-functions
 200                             (luna-find-class (pop parents))
 201                             service)))))
 202     ret))
 203
 204 ;; Return a list of method functions named SERVICE registered in CLASS
 205 ;; and the parents..
 206
 207 (defun luna-class-find-functions (class service)
 208   (let ((sym (luna-class-find-member class service)))
 209     (if (fboundp sym)
 210         (cond ((eq (get sym 'luna-method-qualifier) :before)
 211                (cons (symbol-function sym)
 212                      (luna-class-find-parents-functions class service)))
 213               ((eq (get sym 'luna-method-qualifier) :after)
 214                (nconc (luna-class-find-parents-functions class service)
 215                       (list (symbol-function sym))))
 216               ((eq (get sym 'luna-method-qualifier) :around)
 217                (cons sym (luna-class-find-parents-functions class service)))
 218               (t
 219                (list (symbol-function sym))))
 220       (luna-class-find-parents-functions class service))))
 221
 222
 223 ;;; @ instance (entity)
 224 ;;;
 225
 226 (defmacro luna-class-name (entity)
 227   "Return class-name of the ENTITY."
 228   `(aref ,entity 0))
 229
 230 (defmacro luna-set-class-name (entity name)
 231   `(aset ,entity 0 ,name))
 232
 233 (defmacro luna-get-obarray (entity)
 234   `(aref ,entity 1))
 235
 236 (defmacro luna-set-obarray (entity obarray)
 237   `(aset ,entity 1 ,obarray))
 238
 239 (defmacro luna-slot-index (entity slot-name)
 240   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 241                           ,slot-name))
 242
 243 (defsubst luna-slot-value (entity slot)
 244   "Return the value of SLOT of ENTITY."
 245   (aref entity (luna-slot-index entity slot)))
 246
 247 (defsubst luna-set-slot-value (entity slot value)
 248   "Store VALUE into SLOT of ENTITY."
 249   (aset entity (luna-slot-index entity slot) value))
 250
 251 (defmacro luna-find-functions (entity service)
 252   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 253                               ,service))
 254
 255 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 256   "Send MESSAGE to ENTITY, and return the result.
 257 ENTITY is an instance of a luna class, and MESSAGE is a method name of
 258 the luna class.
 259 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 260   (let ((luna-next-methods (luna-find-functions entity message))
 261         luna-current-method
 262         luna-previous-return-value)
 263     (while (and luna-next-methods
 264                 (progn
 265                   (setq luna-current-method (pop luna-next-methods)
 266                         luna-previous-return-value
 267                         (apply luna-current-method
 268                                luna-current-method-arguments))
 269                   (if (symbolp luna-current-method)
 270                       (not (eq (get luna-current-method
 271                                     'luna-method-qualifier) :around))
 272                     t))))
 273     luna-previous-return-value))
 274
 275 (eval-when-compile
 276   (defvar luna-next-methods nil)
 277   (defvar luna-current-method-arguments nil))
 278
 279 (defun luna-call-next-method ()
 280   "Call the next method in the current method function.
 281 A method function that has :around qualifier should call this function
 282 to execute the parents' methods."
 283   (let (luna-current-method
 284         luna-previous-return-value)
 285     (while (and luna-next-methods
 286                 (progn
 287                   (setq luna-current-method (pop luna-next-methods)
 288                         luna-previous-return-value
 289                         (apply luna-current-method
 290                                luna-current-method-arguments))
 291                   (if (symbolp luna-current-method)
 292                       (not (eq (get luna-current-method
 293                                     'luna-method-qualifier) :around))
 294                     t))))
 295     luna-previous-return-value))
 296
 297 (defun luna-make-entity (class &rest init-args)
 298   "Make an entity (instance) of luna-class CLASS and return it.
 299 INIT-ARGS is a plist of the form (:SLOT1 VAL1 :SLOT2 VAL2 ...),
 300 where SLOTs are slots of CLASS and the VALs are initial values of
 301 the corresponding SLOTs."
 302   (let* ((c (get class 'luna-class))
 303          (v (make-vector (luna-class-number-of-slots c) nil)))
 304     (luna-set-class-name v class)
 305     (luna-set-obarray v (make-vector 7 0))
 306     (apply #'luna-send v 'initialize-instance v init-args)))
 307
 308
 309 ;;; @ interface (generic function)
 310 ;;;
 311
 312 ;; Find a method of ENTITY that handles MESSAGE, and call it with
 313 ;; arguments LUNA-CURRENT-METHOD-ARGUMENTS.
 314
 315 (defun luna-apply-generic (entity message &rest luna-current-method-arguments)
 316   (let* ((class (luna-class-name entity))
 317          (cache (get message 'luna-method-cache))
 318          (sym (intern-soft (symbol-name class) cache))
 319          luna-next-methods)
 320     (if sym
 321         (setq luna-next-methods (symbol-value sym))
 322       (setq luna-next-methods
 323             (luna-find-functions entity message))
 324       (set (intern (symbol-name class) cache)
 325            luna-next-methods))
 326     (luna-call-next-method)))
 327
 328
 329 ;; Convert ARGLIST (argument list spec for a method function) to the
 330 ;; actual list of arguments.
 331
 332 (defsubst luna-arglist-to-arguments (arglist)
 333   (let (dest)
 334     (while arglist
 335       (let ((arg (car arglist)))
 336         (or (memq arg '(&optional &rest))
 337             (setq dest (cons arg dest))))
 338       (setq arglist (cdr arglist)))
 339     (nreverse dest)))
 340
 341
 342 (defmacro luna-define-generic (name args &optional doc)
 343   "Define a function NAME that provides a generic interface to the method NAME.
 344 ARGS is the argument list for NAME.  The first element of ARGS is an
 345 entity.
 346
 347 The function handles a message sent to the entity by calling the
 348 method with proper arguments.
 349
 350 The optional 3rd argument DOC is the documentation string for NAME."
 351   (if doc
 352       `(progn
 353          (defun ,(intern (symbol-name name)) ,args
 354            ,doc
 355            (luna-apply-generic ,(car args) ',name
 356                                ,@(luna-arglist-to-arguments args)))
 357          (put ',name 'luna-method-cache (make-vector 31 0)))
 358     `(progn
 359        (defun ,(intern (symbol-name name)) ,args
 360          (luna-apply-generic ,(car args) ',name
 361                              ,@(luna-arglist-to-arguments args)))
 362        (put ',name 'luna-method-cache (make-vector 31 0)))))
 363
 364 (put 'luna-define-generic 'lisp-indent-function 'defun)
 365
 366
 367 ;;; @ accessor
 368 ;;;
 369
 370 (defun luna-define-internal-accessors (class-name)
 371   "Define internal accessors for instances of the luna class CLASS-NAME.
 372
 373 Internal accessors are macros to refer and set a slot value of the
 374 instances.  For instance, if the class has SLOT, macros
 375 CLASS-NAME-SLOT-internal and CLASS-NAME-set-SLOT-internal are defined.
 376
 377 CLASS-NAME-SLOT-internal accepts one argument INSTANCE, and returns
 378 the value of SLOT.
 379
 380 CLASS-NAME-set-SLOT-internal accepts two arguemnt INSTANCE and VALUE,
 381 and sets SLOT to VALUE."
 382   (let ((entity-class (luna-find-class class-name))
 383         parents parent-class)
 384     (mapatoms
 385      (lambda (slot)
 386        (if (luna-class-slot-index entity-class slot)
 387            (catch 'derived
 388              (setq parents (luna-class-parents entity-class))
 389              (while parents
 390                (setq parent-class (luna-find-class (car parents)))
 391                (if (luna-class-slot-index parent-class slot)
 392                    (throw 'derived nil))
 393                (setq parents (cdr parents)))
 394              (eval
 395               `(progn
 396                  (defmacro ,(intern (format "%s-%s-internal"
 397                                             class-name slot))
 398                    (entity)
 399                    (list 'aref entity
 400                          ,(luna-class-slot-index entity-class
 401                                                  (intern (symbol-name slot)))))
 402                  (defmacro ,(intern (format "%s-set-%s-internal"
 403                                             class-name slot))
 404                    (entity value)
 405                    (list 'aset entity
 406                          ,(luna-class-slot-index
 407                            entity-class (intern (symbol-name slot)))
 408                          value)))))))
 409      (luna-class-obarray entity-class))))
 410
 411
 412 ;;; @ standard object
 413 ;;;
 414
 415 ;; Define super class of all luna classes.
 416 (luna-define-class-function 'standard-object)
 417
 418 (luna-define-method initialize-instance ((entity standard-object)
 419                                          &rest init-args)
 420   "Initialize slots of ENTITY by INIT-ARGS."
 421   (let* ((c (luna-find-class (luna-class-name entity)))
 422          (oa (luna-class-obarray c))
 423          s i)
 424     (while init-args
 425       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 426             i (pop init-args))
 427       (if s
 428           (aset entity (get s 'luna-slot-index) i)))
 429     entity))
 430
 431
 432 ;;; @ end
 433 ;;;
 434
 435 (provide 'luna)
 436
 437 ;; luna.el ends here