1 ;;; luna.el --- tiny OOP system kernel
3 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
8 ;; This file is part of FLIM (Faithful Library about Internet Message).
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.
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.
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.
27 (eval-when-compile (require 'cl))
29 (defmacro luna-find-class (name)
30 "Return the luna-class of the given NAME."
31 `(get ,name 'luna-class))
33 (defmacro luna-set-class (name class)
34 `(put ,name 'luna-class ,class))
36 (defmacro luna-class-obarray (class)
39 (defmacro luna-class-parents (class)
42 (defmacro luna-class-number-of-slots (class)
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))
55 (setq parent (pop rest))
56 (mapatoms (lambda (sym)
57 (when (get sym 'luna-member-index)
58 (setq name (symbol-name sym))
59 (unless (intern-soft name oa)
60 (put (intern name oa) 'luna-member-index i)
63 (luna-class-obarray (luna-find-class parent)))
67 (setq name (symbol-name (pop rest)))
68 (unless (intern-soft name oa)
69 (put (intern name oa) 'luna-member-index i)
72 `(luna-set-class ',type
73 (vector 'class ,oa ',parents ,i))
76 (defmacro luna-class-name (entity)
77 "Return class-name of the ENTITY."
80 (defmacro luna-set-class-name (entity name)
81 `(aset ,entity 0 ,name))
83 (defmacro luna-get-obarray (entity)
86 (defmacro luna-set-obarray (entity obarray)
87 `(aset ,entity 1 ,obarray))
89 (defmacro luna-make-entity (type &rest init-args)
90 "Make instance of luna-class TYPE and return it.
91 If INIT-ARGS is specified, it is used as initial values of the slots.
92 It must be plist and each slot name must have prefix `:'."
93 `(apply #'luna-make-entity-function ',type ',init-args))
95 (defsubst luna-make-entity-function (type &rest init-args)
96 (let* ((c (get type 'luna-class))
97 (v (make-vector (luna-class-number-of-slots c) nil))
98 (oa (luna-class-obarray c))
100 (luna-set-class-name v type)
101 (luna-set-obarray v (make-vector 7 0))
103 (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
106 (aset v (get s 'luna-member-index) i)
110 (defsubst luna-class-find-member (class member-name)
111 (or (stringp member-name)
112 (setq member-name (symbol-name member-name)))
113 (or (intern-soft member-name (luna-class-obarray class))
114 (let ((parents (luna-class-parents class))
118 (setq ret (luna-class-find-member
119 (luna-find-class (pop parents))
123 (defsubst luna-class-find-or-make-member (class member-name)
124 (or (stringp member-name)
125 (setq member-name (symbol-name member-name)))
126 (intern member-name (luna-class-obarray class)))
128 (defmacro luna-class-slot-index (class slot-name)
129 `(get (luna-class-find-member ,class ,slot-name) 'luna-member-index))
131 (defmacro luna-slot-index (entity slot-name)
132 `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
135 (defsubst luna-slot-value (entity slot)
136 "Return the value of SLOT of ENTITY."
137 (aref entity (luna-slot-index entity slot)))
139 (defsubst luna-set-slot-value (entity slot value)
140 "Store VALUE into SLOT of ENTITY."
141 (aset entity (luna-slot-index entity slot) value))
143 (defmacro luna-define-method (name args &rest body)
144 "Define NAME as a method function of (nth 1 (car ARGS)) backend.
146 ARGS is like an argument list of lambda, but (car ARGS) must be
147 specialized parameter. (car (car ARGS)) is name of variable and (nth
148 1 (car ARGS)) is name of backend."
149 (let* ((specializer (car args))
150 (class (nth 1 specializer))
151 (self (car specializer)))
152 `(let ((func (lambda ,(if self
153 (cons self (cdr args))
156 (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name)
159 (put 'luna-define-method 'lisp-indent-function 'defun)
161 (defsubst luna-class-find-function (class service)
162 (let ((sym (luna-class-find-member class service)))
164 (symbol-function sym)
165 (let ((parents (luna-class-parents class))
169 (setq ret (luna-class-find-function
170 (luna-find-class (pop parents))
174 (defmacro luna-find-function (entity service)
175 `(luna-class-find-function (luna-find-class (luna-class-name ,entity))
178 (defsubst luna-send (entity message &rest args)
179 "Send MESSAGE to ENTITY with ARGS, and return the result."
180 (apply (luna-find-function entity message)
183 (defsubst luna-arglist-to-arguments (arglist)
186 (let ((arg (car arglist)))
187 (or (memq arg '(&optional &rest))
188 (setq dest (cons arg dest)))
190 (setq arglist (cdr arglist)))
193 (defmacro luna-define-generic (name args &optional doc)
194 "Define generic-function NAME.
195 ARGS is argument of and DOC is DOC-string."
197 `(defun ,(intern (symbol-name name)) ,args
199 (luna-send ,(car args) ',name
200 ,@(luna-arglist-to-arguments (cdr args)))
202 `(defun ,(intern (symbol-name name)) ,args
203 (luna-send ,(car args) ',name
204 ,@(luna-arglist-to-arguments (cdr args)))
207 (put 'luna-define-generic 'lisp-indent-function 'defun)