luna.el

   1 ;;; luna.el --- tiny OOP system kernel
   2
   3 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   7 ;; Keywords: OOP
   8
   9 ;; This file is part of FLIM (Faithful Library about Internet Message).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (eval-when-compile (require 'static))
  31
  32 (static-condition-case nil
  33     :symbol-for-testing-whether-colon-keyword-is-available-or-not
  34   (void-variable
  35    (defconst :before ':before)
  36    (defconst :after ':after)
  37    (defconst :around ':around)))
  38
  39 (defmacro luna-find-class (name)
  40   "Return the luna-class of the given NAME."
  41   (` (get (, name) 'luna-class)))
  42
  43 (defmacro luna-set-class (name class)
  44   (` (put (, name) 'luna-class (, class))))
  45
  46 (defmacro luna-class-obarray (class)
  47   (` (aref (, class) 1)))
  48
  49 (defmacro luna-class-parents (class)
  50   (` (aref (, class) 2)))
  51
  52 (defmacro luna-class-number-of-slots (class)
  53   (` (aref (, class) 3)))
  54
  55 (defmacro luna-define-class (type &optional parents slots)
  56   "Define TYPE as a luna-class.
  57 If PARENTS is specified, TYPE inherits PARENTS.
  58 Each parent must be name of luna-class (symbol).
  59 If SLOTS is specified, TYPE will be defined to have them."
  60   (` (luna-define-class-function '(, type)
  61                                  '(, (append parents '(standard-object)))
  62                                  '(, slots))))
  63
  64 (defun luna-define-class-function (type &optional parents slots)
  65   (static-condition-case nil
  66       :symbol-for-testing-whether-colon-keyword-is-available-or-not
  67     (void-variable
  68      (let (key)
  69        (dolist (slot slots)
  70          (setq key (intern (format ":%s" slot)))
  71          (set key key)))))
  72   (let ((oa (make-vector 31 0))
  73         (rest parents)
  74         parent name
  75         (i 2)
  76         b j)
  77     (while rest
  78       (setq parent (pop rest)
  79             b (- i 2))
  80       (mapatoms (function
  81                  (lambda (sym)
  82                    (when (setq j (get sym 'luna-slot-index))
  83                      (setq name (symbol-name sym))
  84                      (unless (intern-soft name oa)
  85                        (put (intern name oa) 'luna-slot-index (+ j b))
  86                        (setq i (1+ i))
  87                        ))))
  88                 (luna-class-obarray (luna-find-class parent)))
  89       )
  90     (setq rest slots)
  91     (while rest
  92       (setq name (symbol-name (pop rest)))
  93       (unless (intern-soft name oa)
  94         (put (intern name oa) 'luna-slot-index i)
  95         (setq i (1+ i))
  96         ))
  97     (luna-set-class type (vector 'class oa parents i))
  98     ))
  99
 100 (defun luna-class-find-member (class member-name)
 101   (or (stringp member-name)
 102       (setq member-name (symbol-name member-name)))
 103   (or (intern-soft member-name (luna-class-obarray class))
 104       (let ((parents (luna-class-parents class))
 105             ret)
 106         (while (and parents
 107                     (null
 108                      (setq ret (luna-class-find-member
 109                                 (luna-find-class (pop parents))
 110                                 member-name)))))
 111         ret)))
 112
 113 (defsubst luna-class-find-or-make-member (class member-name)
 114   (or (stringp member-name)
 115       (setq member-name (symbol-name member-name)))
 116   (intern member-name (luna-class-obarray class)))
 117
 118 (defmacro luna-class-slot-index (class slot-name)
 119   (` (get (luna-class-find-member (, class) (, slot-name)) 'luna-slot-index)))
 120
 121 (defmacro luna-slot-index (entity slot-name)
 122   (` (luna-class-slot-index (luna-find-class (luna-class-name (, entity)))
 123                             (, slot-name))))
 124
 125 (defsubst luna-slot-value (entity slot)
 126   "Return the value of SLOT of ENTITY."
 127   (aref entity (luna-slot-index entity slot)))
 128
 129 (defsubst luna-set-slot-value (entity slot value)
 130   "Store VALUE into SLOT of ENTITY."
 131   (aset entity (luna-slot-index entity slot) value))
 132
 133 (defmacro luna-define-method (name &rest definition)
 134   "Define NAME as a method function of a class.
 135
 136 Usage of this macro follows:
 137
 138   (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
 139
 140 NAME is the name of method.
 141
 142 Optional argument METHOD-QUALIFIER must be :before, :after or :around.
 143 If it is :before / :after, the method is called before / after a
 144 method of parent class is finished.  ARGLIST is like an argument list
 145 of lambda, but (car ARGLIST) must be specialized parameter.  (car (car
 146 ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
 147 class.
 148
 149 Optional argument DOCSTRING is the documentation of method.
 150
 151 BODY is the body of method."
 152   (let ((method-qualifier (pop definition))
 153         args specializer class self)
 154     (if (memq method-qualifier '(:before :after :around))
 155         (setq args (pop definition))
 156       (setq args method-qualifier
 157             method-qualifier nil)
 158       )
 159     (setq specializer (car args)
 160           class (nth 1 specializer)
 161           self (car specializer))
 162     (` (let ((func (function
 163                     (lambda (, (if self
 164                                    (cons self (cdr args))
 165                                  (cdr args)))
 166                       (,@ definition))))
 167              (sym (luna-class-find-or-make-member
 168                    (luna-find-class '(, class)) '(, name))))
 169          (fset sym func)
 170          (put sym 'luna-method-qualifier (, method-qualifier))
 171          ))
 172     ))
 173
 174 (put 'luna-define-method 'lisp-indent-function 'defun)
 175
 176 (def-edebug-spec luna-define-method
 177   (&define name [&optional &or ":before" ":after" ":around"]
 178            ((arg symbolp)
 179             [&rest arg]
 180             [&optional ["&optional" arg &rest arg]]
 181             &optional ["&rest" arg]
 182             )
 183            def-body))
 184
 185 (defun luna-class-find-parents-functions (class service)
 186   (let ((parents (luna-class-parents class))
 187         ret)
 188     (while (and parents
 189                 (null
 190                  (setq ret (luna-class-find-functions
 191                             (luna-find-class (pop parents))
 192                             service)))))
 193     ret))
 194
 195 (defun luna-class-find-functions (class service)
 196   (let ((sym (luna-class-find-member class service)))
 197     (if (fboundp sym)
 198         (cond ((eq (get sym 'luna-method-qualifier) :before)
 199                (cons (symbol-function sym)
 200                      (luna-class-find-parents-functions class service))
 201                )
 202               ((eq (get sym 'luna-method-qualifier) :after)
 203                (nconc (luna-class-find-parents-functions class service)
 204                       (list (symbol-function sym)))
 205                )
 206               ((eq (get sym 'luna-method-qualifier) :around)
 207                (cons sym (luna-class-find-parents-functions class service))
 208                )
 209               (t
 210                (list (symbol-function sym))
 211                ))
 212       (luna-class-find-parents-functions class service)
 213       )))
 214
 215 (defmacro luna-find-functions (entity service)
 216   (` (luna-class-find-functions (luna-find-class (luna-class-name (, entity)))
 217                                 (, service))))
 218
 219 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 220   "Send MESSAGE to ENTITY, and return the result.
 221 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 222   (let ((luna-next-methods (luna-find-functions entity message))
 223         luna-current-method
 224         luna-previous-return-value)
 225     (while (and luna-next-methods
 226                 (progn
 227                   (setq luna-current-method (pop luna-next-methods)
 228                         luna-previous-return-value
 229                         (apply luna-current-method
 230                                luna-current-method-arguments))
 231                   (if (symbolp luna-current-method)
 232                       (not (eq (get luna-current-method
 233                                     'luna-method-qualifier) :around))
 234                     t))))
 235     luna-previous-return-value))
 236
 237 (eval-when-compile
 238   (defvar luna-next-methods nil)
 239   (defvar luna-current-method-arguments nil)
 240   )
 241
 242 (defun luna-call-next-method ()
 243   "Call the next method in a method with :around qualifier."
 244   (let (luna-current-method
 245         luna-previous-return-value)
 246     (while (and luna-next-methods
 247                 (progn
 248                   (setq luna-current-method (pop luna-next-methods)
 249                         luna-previous-return-value
 250                         (apply luna-current-method
 251                                luna-current-method-arguments))
 252                   (if (symbolp luna-current-method)
 253                       (not (eq (get luna-current-method
 254                                     'luna-method-qualifier) :around))
 255                     t))))
 256     luna-previous-return-value))
 257
 258 (defmacro luna-class-name (entity)
 259   "Return class-name of the ENTITY."
 260   (` (aref (, entity) 0)))
 261
 262 (defmacro luna-set-class-name (entity name)
 263   (` (aset (, entity) 0 (, name))))
 264
 265 (defmacro luna-get-obarray (entity)
 266   (` (aref (, entity) 1)))
 267
 268 (defmacro luna-set-obarray (entity obarray)
 269   (` (aset (, entity) 1 (, obarray))))
 270
 271 (defun luna-make-entity (type &rest init-args)
 272   "Make instance of luna-class TYPE and return it.
 273 If INIT-ARGS is specified, it is used as initial values of the slots.
 274 It must be plist and each slot name must have prefix `:'."
 275   (let* ((c (get type 'luna-class))
 276          (v (make-vector (luna-class-number-of-slots c) nil)))
 277     (luna-set-class-name v type)
 278     (luna-set-obarray v (make-vector 7 0))
 279     (apply (function luna-send) v 'initialize-instance v init-args)
 280     ))
 281
 282 (defsubst luna-arglist-to-arguments (arglist)
 283   (let (dest)
 284     (while arglist
 285       (let ((arg (car arglist)))
 286         (or (memq arg '(&optional &rest))
 287             (setq dest (cons arg dest)))
 288         )
 289       (setq arglist (cdr arglist)))
 290     (nreverse dest)))
 291
 292 (defmacro luna-define-generic (name args &optional doc)
 293   "Define generic-function NAME.
 294 ARGS is argument of and DOC is DOC-string."
 295   (if doc
 296       (` (defun (, (intern (symbol-name name))) (, args)
 297            (, doc)
 298            (luna-send (, (car args)) '(, name)
 299                       (,@ (luna-arglist-to-arguments args)))
 300            ))
 301     (` (defun (, (intern (symbol-name name))) (, args)
 302          (luna-send (, (car args)) '(, name)
 303                     (,@ (luna-arglist-to-arguments args)))
 304          ))))
 305
 306 (put 'luna-define-generic 'lisp-indent-function 'defun)
 307
 308 (defun luna-define-internal-accessors (class-name)
 309   "Define internal accessors for an entity of CLASS-NAME."
 310   (let ((entity-class (luna-find-class class-name))
 311         parents parent-class)
 312     (mapatoms
 313      (function
 314       (lambda (slot)
 315         (if (luna-class-slot-index entity-class slot)
 316             (catch 'derived
 317               (setq parents (luna-class-parents entity-class))
 318               (while parents
 319                 (setq parent-class (luna-find-class (car parents)))
 320                 (if (luna-class-slot-index parent-class slot)
 321                     (throw 'derived nil))
 322                 (setq parents (cdr parents))
 323                 )
 324               (eval
 325                (` (progn
 326                     (defmacro (, (intern (format "%s-%s-internal"
 327                                                  class-name slot)))
 328                       (entity)
 329                       (list 'aref entity
 330                             (, (luna-class-slot-index entity-class
 331                                                       (intern (symbol-name slot))))
 332                             ))
 333                     (defmacro (, (intern (format "%s-set-%s-internal"
 334                                                  class-name slot)))
 335                       (entity value)
 336                       (list 'aset entity
 337                             (, (luna-class-slot-index
 338                                 entity-class (intern (symbol-name slot))))
 339                             value))
 340                     )))
 341               ))))
 342      (luna-class-obarray entity-class))))
 343
 344 (luna-define-class-function 'standard-object)
 345
 346 (luna-define-method initialize-instance ((entity standard-object)
 347                                          &rest init-args)
 348   (let* ((c (luna-find-class (luna-class-name entity)))
 349          (oa (luna-class-obarray c))
 350          s i)
 351     (while init-args
 352       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 353             i (pop init-args))
 354       (if s
 355           (aset entity (get s 'luna-slot-index) i)
 356         ))
 357     entity))
 358
 359
 360 ;;; @ end
 361 ;;;
 362
 363 (provide 'luna)
 364
 365 ;; luna.el ends here