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 :after.  If it is :after,
 125 the method is called after a method of parent class is finished.
 126 ARGLIST is like an argument list of lambda, but (car ARGLIST) must be
 127 specialized parameter.  (car (car ARGLIST)) is name of variable and
 128 \(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 (eq method-qualifier :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 ":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         (if (eq (get sym 'luna-method-qualifier) :after)
 178             (nconc (luna-class-find-parents-functions class service)
 179                    (list (symbol-function sym)))
 180           (list (symbol-function sym))
 181           )
 182       (luna-class-find-parents-functions class service)
 183       )))
 184
 185 (defmacro luna-find-functions (entity service)
 186   `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
 187                               ,service))
 188
 189 (defsubst luna-send (entity message &rest args)
 190   "Send MESSAGE to ENTITY with ARGS, and return the result."
 191   (let ((functions (luna-find-functions entity message))
 192         ret)
 193     (while functions
 194       (setq ret (apply (car functions) args)
 195             functions (cdr functions))
 196       )
 197     ret))
 198
 199 (defmacro luna-class-name (entity)
 200   "Return class-name of the ENTITY."
 201   `(aref ,entity 0))
 202
 203 (defmacro luna-set-class-name (entity name)
 204   `(aset ,entity 0 ,name))
 205
 206 (defmacro luna-get-obarray (entity)
 207   `(aref ,entity 1))
 208
 209 (defmacro luna-set-obarray (entity obarray)
 210   `(aset ,entity 1 ,obarray))
 211
 212 (defun luna-make-entity (type &rest init-args)
 213   "Make instance of luna-class TYPE and return it.
 214 If INIT-ARGS is specified, it is used as initial values of the slots.
 215 It must be plist and each slot name must have prefix `:'."
 216   (let* ((c (get type 'luna-class))
 217          (v (make-vector (luna-class-number-of-slots c) nil)))
 218     (luna-set-class-name v type)
 219     (luna-set-obarray v (make-vector 7 0))
 220     (apply #'luna-send v 'initialize-instance v init-args)
 221     ))
 222
 223 (defsubst luna-arglist-to-arguments (arglist)
 224   (let (dest)
 225     (while arglist
 226       (let ((arg (car arglist)))
 227         (or (memq arg '(&optional &rest))
 228             (setq dest (cons arg dest)))
 229         )
 230       (setq arglist (cdr arglist)))
 231     (nreverse dest)))
 232
 233 (defmacro luna-define-generic (name args &optional doc)
 234   "Define generic-function NAME.
 235 ARGS is argument of and DOC is DOC-string."
 236   (if doc
 237       `(defun ,(intern (symbol-name name)) ,args
 238          ,doc
 239          (luna-send ,(car args) ',name
 240                     ,@(luna-arglist-to-arguments args))
 241          )
 242     `(defun ,(intern (symbol-name name)) ,args
 243        (luna-send ,(car args) ',name
 244                   ,@(luna-arglist-to-arguments args))
 245        )))
 246
 247 (put 'luna-define-generic 'lisp-indent-function 'defun)
 248
 249 (defun luna-define-internal-accessors (class-name)
 250   "Define internal accessors for an entity of CLASS-NAME."
 251   (let ((entity-class (luna-find-class class-name))
 252         parents parent-class)
 253     (mapatoms
 254      (lambda (slot)
 255        (if (luna-class-slot-index entity-class slot)
 256            (catch 'derived
 257              (setq parents (luna-class-parents entity-class))
 258              (while parents
 259                (setq parent-class (luna-find-class (car parents)))
 260                (if (luna-class-slot-index parent-class slot)
 261                    (throw 'derived nil))
 262                (setq parents (cdr parents))
 263                )
 264              (eval
 265               `(progn
 266                  (defmacro ,(intern (format "%s-%s-internal"
 267                                             class-name slot))
 268                    (entity)
 269                    (list 'aref entity
 270                          ,(luna-class-slot-index entity-class
 271                                                  (intern (symbol-name slot)))
 272                          ))
 273                  (defmacro ,(intern (format "%s-set-%s-internal"
 274                                             class-name slot))
 275                    (entity value)
 276                    (list 'aset entity
 277                          ,(luna-class-slot-index
 278                            entity-class (intern (symbol-name slot)))
 279                          value))
 280                  ))
 281              )))
 282      (luna-class-obarray entity-class))))
 283
 284 (luna-define-class-function 'standard-object)
 285
 286 (luna-define-method initialize-instance ((entity standard-object)
 287                                          &rest init-args)
 288   (let* ((c (luna-find-class (luna-class-name entity)))
 289          (oa (luna-class-obarray c))
 290          s i)
 291     (while init-args
 292       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 293             i (pop init-args))
 294       (if s
 295           (aset entity (get s 'luna-slot-index) i)
 296         ))
 297     entity))
 298
 299
 300 ;;; @ end
 301 ;;;
 302
 303 (provide 'luna)
 304
 305 ;; luna.el ends here