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