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