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 ',(append parents '(standard-object))
  61                                ',slots))
  62
  63 (defun luna-define-class-function (type &optional parents slots)
  64   (static-condition-case nil
  65       :symbol-for-testing-whether-colon-keyword-is-available-or-not
  66     (void-variable
  67      (let (key)
  68        (dolist (slot slots)
  69          (setq key (intern (format ":%s" slot)))
  70          (set key key)))))
  71   (let ((oa (make-vector 31 0))
  72         (rest parents)
  73         parent name
  74         (i 2)
  75         b j)
  76     (while rest
  77       (setq parent (pop rest)
  78             b (- i 2))
  79       (mapatoms (lambda (sym)
  80                   (when (setq j (get sym 'luna-slot-index))
  81                     (setq name (symbol-name sym))
  82                     (unless (intern-soft name oa)
  83                       (put (intern name oa) 'luna-slot-index (+ j b))
  84                       (setq i (1+ i))
  85                       )))
  86                 (luna-class-obarray (luna-find-class parent)))
  87       )
  88     (setq rest slots)
  89     (while rest
  90       (setq name (symbol-name (pop rest)))
  91       (unless (intern-soft name oa)
  92         (put (intern name oa) 'luna-slot-index i)
  93         (setq i (1+ i))
  94         ))
  95     (luna-set-class type (vector 'class oa parents i))
  96     ))
  97
  98 (defun luna-class-find-member (class member-name)
  99   (or (stringp member-name)
 100       (setq member-name (symbol-name member-name)))
 101   (or (intern-soft member-name (luna-class-obarray class))
 102       (let ((parents (luna-class-parents class))
 103             ret)
 104         (while (and parents
 105                     (null
 106                      (setq ret (luna-class-find-member
 107                                 (luna-find-class (pop parents))
 108                                 member-name)))))
 109         ret)))
 110
 111 (defsubst luna-class-find-or-make-member (class member-name)
 112   (or (stringp member-name)
 113       (setq member-name (symbol-name member-name)))
 114   (intern member-name (luna-class-obarray class)))
 115
 116 (defmacro luna-class-slot-index (class slot-name)
 117   `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
 118
 119 (defmacro luna-slot-index (entity slot-name)
 120   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 121                           ,slot-name))
 122
 123 (defsubst luna-slot-value (entity slot)
 124   "Return the value of SLOT of ENTITY."
 125   (aref entity (luna-slot-index entity slot)))
 126
 127 (defsubst luna-set-slot-value (entity slot value)
 128   "Store VALUE into SLOT of ENTITY."
 129   (aset entity (luna-slot-index entity slot) value))
 130
 131 (defmacro luna-define-method (name &rest definition)
 132   "Define NAME as a method function of a class.
 133
 134 Usage of this macro follows:
 135
 136   (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
 137
 138 NAME is the name of method.
 139
 140 Optional argument METHOD-QUALIFIER must be :before, :after or :around.
 141 If it is :before / :after, the method is called before / after a
 142 method of parent class is finished.  ARGLIST is like an argument list
 143 of lambda, but (car ARGLIST) must be specialized parameter.  (car (car
 144 ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
 145 class.
 146
 147 Optional argument DOCSTRING is the documentation of method.
 148
 149 BODY is the body of method."
 150   (let ((method-qualifier (pop definition))
 151         args specializer class self)
 152     (if (memq method-qualifier '(:before :after :around))
 153         (setq args (pop definition))
 154       (setq args method-qualifier
 155             method-qualifier nil)
 156       )
 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        (fset sym func)
 167        (put sym 'luna-method-qualifier ,method-qualifier)
 168        )))
 169
 170 (put 'luna-define-method 'lisp-indent-function 'defun)
 171
 172 (def-edebug-spec luna-define-method
 173   (&define name [&optional &or ":before" ":after" ":around"]
 174            ((arg symbolp)
 175             [&rest arg]
 176             [&optional ["&optional" arg &rest arg]]
 177             &optional ["&rest" arg]
 178             )
 179            def-body))
 180
 181 (defun luna-class-find-parents-functions (class service)
 182   (let ((parents (luna-class-parents class))
 183         ret)
 184     (while (and parents
 185                 (null
 186                  (setq ret (luna-class-find-functions
 187                             (luna-find-class (pop parents))
 188                             service)))))
 189     ret))
 190
 191 (defun luna-class-find-functions (class service)
 192   (let ((sym (luna-class-find-member class service)))
 193     (if (fboundp sym)
 194         (cond ((eq (get sym 'luna-method-qualifier) :before)
 195                (cons (symbol-function sym)
 196                      (luna-class-find-parents-functions class service))
 197                )
 198               ((eq (get sym 'luna-method-qualifier) :after)
 199                (nconc (luna-class-find-parents-functions class service)
 200                       (list (symbol-function sym)))
 201                )
 202               ((eq (get sym 'luna-method-qualifier) :around)
 203                (cons sym (luna-class-find-parents-functions class service))
 204                )
 205               (t
 206                (list (symbol-function sym))
 207                ))
 208       (luna-class-find-parents-functions class service)
 209       )))
 210
 211 (defmacro luna-find-functions (entity service)
 212   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 213                               ,service))
 214
 215 (defsubst luna-send (entity message &rest luna-current-method-arguments)
 216   "Send MESSAGE to ENTITY, and return the result.
 217 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
 218   (let ((luna-next-methods (luna-find-functions entity message))
 219         luna-current-method
 220         luna-previous-return-value)
 221     (while (and luna-next-methods
 222                 (progn
 223                   (setq luna-current-method (pop luna-next-methods)
 224                         luna-previous-return-value
 225                         (apply luna-current-method
 226                                luna-current-method-arguments))
 227                   (if (symbolp luna-current-method)
 228                       (not (eq (get luna-current-method
 229                                     'luna-method-qualifier) :around))
 230                     t))))
 231     luna-previous-return-value))
 232
 233 (eval-when-compile
 234   (defvar luna-next-methods nil)
 235   (defvar luna-current-method-arguments nil)
 236   )
 237
 238 (defun luna-call-next-method ()
 239   "Call the next method in a method with :around qualifier."
 240   (let (luna-current-method
 241         luna-previous-return-value)
 242     (while (and luna-next-methods
 243                 (progn
 244                   (setq luna-current-method (pop luna-next-methods)
 245                         luna-previous-return-value
 246                         (apply luna-current-method
 247                                luna-current-method-arguments))
 248                   (if (symbolp luna-current-method)
 249                       (not (eq (get luna-current-method
 250                                     'luna-method-qualifier) :around))
 251                     t))))
 252     luna-previous-return-value))
 253
 254 (defmacro luna-class-name (entity)
 255   "Return class-name of the ENTITY."
 256   `(aref ,entity 0))
 257
 258 (defmacro luna-set-class-name (entity name)
 259   `(aset ,entity 0 ,name))
 260
 261 (defmacro luna-get-obarray (entity)
 262   `(aref ,entity 1))
 263
 264 (defmacro luna-set-obarray (entity obarray)
 265   `(aset ,entity 1 ,obarray))
 266
 267 (defun luna-make-entity (type &rest init-args)
 268   "Make instance of luna-class TYPE and return it.
 269 If INIT-ARGS is specified, it is used as initial values of the slots.
 270 It must be plist and each slot name must have prefix `:'."
 271   (let* ((c (get type 'luna-class))
 272          (v (make-vector (luna-class-number-of-slots c) nil)))
 273     (luna-set-class-name v type)
 274     (luna-set-obarray v (make-vector 7 0))
 275     (apply #'luna-send v 'initialize-instance v init-args)
 276     ))
 277
 278 (defsubst luna-arglist-to-arguments (arglist)
 279   (let (dest)
 280     (while arglist
 281       (let ((arg (car arglist)))
 282         (or (memq arg '(&optional &rest))
 283             (setq dest (cons arg dest)))
 284         )
 285       (setq arglist (cdr arglist)))
 286     (nreverse dest)))
 287
 288 (defmacro luna-define-generic (name args &optional doc)
 289   "Define generic-function NAME.
 290 ARGS is argument of and DOC is DOC-string."
 291   (if doc
 292       `(defun ,(intern (symbol-name name)) ,args
 293          ,doc
 294          (luna-send ,(car args) ',name
 295                     ,@(luna-arglist-to-arguments args))
 296          )
 297     `(defun ,(intern (symbol-name name)) ,args
 298        (luna-send ,(car args) ',name
 299                   ,@(luna-arglist-to-arguments args))
 300        )))
 301
 302 (put 'luna-define-generic 'lisp-indent-function 'defun)
 303
 304 (defun luna-define-internal-accessors (class-name)
 305   "Define internal accessors for an entity of CLASS-NAME."
 306   (let ((entity-class (luna-find-class class-name))
 307         parents parent-class)
 308     (mapatoms
 309      (lambda (slot)
 310        (if (luna-class-slot-index entity-class slot)
 311            (catch 'derived
 312              (setq parents (luna-class-parents entity-class))
 313              (while parents
 314                (setq parent-class (luna-find-class (car parents)))
 315                (if (luna-class-slot-index parent-class slot)
 316                    (throw 'derived nil))
 317                (setq parents (cdr parents))
 318                )
 319              (eval
 320               `(progn
 321                  (defmacro ,(intern (format "%s-%s-internal"
 322                                             class-name slot))
 323                    (entity)
 324                    (list 'aref entity
 325                          ,(luna-class-slot-index entity-class
 326                                                  (intern (symbol-name slot)))
 327                          ))
 328                  (defmacro ,(intern (format "%s-set-%s-internal"
 329                                             class-name slot))
 330                    (entity value)
 331                    (list 'aset entity
 332                          ,(luna-class-slot-index
 333                            entity-class (intern (symbol-name slot)))
 334                          value))
 335                  ))
 336              )))
 337      (luna-class-obarray entity-class))))
 338
 339 (luna-define-class-function 'standard-object)
 340
 341 (luna-define-method initialize-instance ((entity standard-object)
 342                                          &rest init-args)
 343   (let* ((c (luna-find-class (luna-class-name entity)))
 344          (oa (luna-class-obarray c))
 345          s i)
 346     (while init-args
 347       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 348             i (pop init-args))
 349       (if s
 350           (aset entity (get s 'luna-slot-index) i)
 351         ))
 352     entity))
 353
 354
 355 ;;; @ end
 356 ;;;
 357
 358 (provide 'luna)
 359
 360 ;; luna.el ends here