luna.el

   1 ;;; luna.el --- tiny OOP system kernel
   2
   3 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
   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 (defmacro luna-find-class (name)
  30   "Return the luna-class of the given NAME."
  31   `(get ,name 'luna-class))
  32
  33 (defmacro luna-set-class (name class)
  34   `(put ,name 'luna-class ,class))
  35
  36 (defmacro luna-class-obarray (class)
  37   `(aref ,class 1))
  38
  39 (defmacro luna-class-parents (class)
  40   `(aref ,class 2))
  41
  42 (defmacro luna-class-number-of-slots (class)
  43   `(aref ,class 3))
  44
  45 (defmacro luna-define-class (type &optional parents slots)
  46   "Define TYPE as a luna-class.
  47 If PARENTS is specified, TYPE inherits PARENTS.
  48 Each parent must be name of luna-class (symbol).
  49 If SLOTS is specified, TYPE will be defined to have them."
  50   (let ((oa (make-vector 31 0))
  51         (rest parents)
  52         parent name
  53         (i 2)
  54         b j)
  55     (while rest
  56       (setq parent (pop rest)
  57             b (- i 2))
  58       (mapatoms (lambda (sym)
  59                   (when (setq j (get sym 'luna-member-index))
  60                     (setq name (symbol-name sym))
  61                     (unless (intern-soft name oa)
  62                       (put (intern name oa) 'luna-member-index (+ j b))
  63                       (setq i (1+ i))
  64                       )))
  65                 (luna-class-obarray (luna-find-class parent)))
  66       )
  67     (setq rest slots)
  68     (while rest
  69       (setq name (symbol-name (pop rest)))
  70       (unless (intern-soft name oa)
  71         (put (intern name oa) 'luna-member-index i)
  72         (setq i (1+ i))
  73         ))
  74     `(luna-set-class ',type
  75                      (vector 'class ,oa ',parents ,i))
  76     ))
  77
  78 (defmacro luna-class-name (entity)
  79   "Return class-name of the ENTITY."
  80   `(aref ,entity 0))
  81
  82 (defmacro luna-set-class-name (entity name)
  83   `(aset ,entity 0 ,name))
  84
  85 (defmacro luna-get-obarray (entity)
  86   `(aref ,entity 1))
  87
  88 (defmacro luna-set-obarray (entity obarray)
  89   `(aset ,entity 1 ,obarray))
  90
  91 (defmacro luna-make-entity (type &rest init-args)
  92   "Make instance of luna-class TYPE and return it.
  93 If INIT-ARGS is specified, it is used as initial values of the slots.
  94 It must be plist and each slot name must have prefix `:'."
  95   `(apply #'luna-make-entity-function ',type ',init-args))
  96
  97 (defsubst luna-make-entity-function (type &rest init-args)
  98   (let* ((c (get type 'luna-class))
  99          (v (make-vector (luna-class-number-of-slots c) nil))
 100          (oa (luna-class-obarray c))
 101          s i)
 102     (luna-set-class-name v type)
 103     (luna-set-obarray v (make-vector 7 0))
 104     (while init-args
 105       (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
 106             i (pop init-args))
 107       (if s
 108           (aset v (get s 'luna-member-index) i)
 109         ))
 110     (luna-send v 'initialize-instance v)
 111     v))
 112
 113 (defsubst luna-class-find-member (class member-name)
 114   (or (stringp member-name)
 115       (setq member-name (symbol-name member-name)))
 116   (or (intern-soft member-name (luna-class-obarray class))
 117       (let ((parents (luna-class-parents class))
 118             ret)
 119         (while (and parents
 120                     (null
 121                      (setq ret (luna-class-find-member
 122                                 (luna-find-class (pop parents))
 123                                 member-name)))))
 124         ret)))
 125
 126 (defsubst luna-class-find-or-make-member (class member-name)
 127   (or (stringp member-name)
 128       (setq member-name (symbol-name member-name)))
 129   (intern member-name (luna-class-obarray class)))
 130
 131 (defmacro luna-class-slot-index (class slot-name)
 132   `(get (luna-class-find-member ,class ,slot-name) 'luna-member-index))
 133
 134 (defmacro luna-slot-index (entity slot-name)
 135   `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
 136                           ,slot-name))
 137
 138 (defsubst luna-slot-value (entity slot)
 139   "Return the value of SLOT of ENTITY."
 140   (aref entity (luna-slot-index entity slot)))
 141
 142 (defsubst luna-set-slot-value (entity slot value)
 143   "Store VALUE into SLOT of ENTITY."
 144   (aset entity (luna-slot-index entity slot) value))
 145
 146 (defmacro luna-define-method (name args &rest body)
 147   "Define NAME as a method function of (nth 1 (car ARGS)) backend.
 148
 149 ARGS is like an argument list of lambda, but (car ARGS) must be
 150 specialized parameter.  (car (car ARGS)) is name of variable and (nth
 151 1 (car ARGS)) is name of backend."
 152   (let* ((specializer (car args))
 153          (class (nth 1 specializer))
 154          (self (car specializer)))
 155     `(let ((func (lambda ,(if self
 156                               (cons self (cdr args))
 157                             (cdr args))
 158                    ,@body)))
 159        (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name)
 160              func))))
 161
 162 (put 'luna-define-method 'lisp-indent-function 'defun)
 163
 164 (defsubst luna-class-find-function (class service)
 165   (let ((sym (luna-class-find-member class service)))
 166     (if (fboundp sym)
 167         (symbol-function sym)
 168       (let ((parents (luna-class-parents class))
 169             ret)
 170         (while (and parents
 171                     (null
 172                      (setq ret (luna-class-find-function
 173                                 (luna-find-class (pop parents))
 174                                 service)))))
 175         ret))))
 176
 177 (defmacro luna-find-function (entity service)
 178   `(luna-class-find-function (luna-find-class (luna-class-name ,entity))
 179                              ,service))
 180
 181 (defsubst luna-send (entity message &rest args)
 182   "Send MESSAGE to ENTITY with ARGS, and return the result."
 183   (apply (luna-find-function entity message)
 184          entity args))
 185
 186 (defsubst luna-arglist-to-arguments (arglist)
 187   (let (dest)
 188     (while arglist
 189       (let ((arg (car arglist)))
 190         (or (memq arg '(&optional &rest))
 191             (setq dest (cons arg dest)))
 192         )
 193       (setq arglist (cdr arglist)))
 194     (nreverse dest)))
 195
 196 (defmacro luna-define-generic (name args &optional doc)
 197   "Define generic-function NAME.
 198 ARGS is argument of and DOC is DOC-string."
 199   (if doc
 200       `(defun ,(intern (symbol-name name)) ,args
 201          ,doc
 202          (luna-send ,(car args) ',name
 203                     ,@(luna-arglist-to-arguments (cdr args)))
 204          )
 205     `(defun ,(intern (symbol-name name)) ,args
 206        (luna-send ,(car args) ',name
 207                   ,@(luna-arglist-to-arguments (cdr args)))
 208        )))
 209
 210 (put 'luna-define-generic 'lisp-indent-function 'defun)
 211
 212
 213 ;;; @ end
 214 ;;;
 215
 216 (provide 'luna)
 217
 218 ;; luna.el ends here