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