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