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