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