1 ;;; luna.el --- tiny OOP system kernel
3 ;; Copyright (C) 1999,2000 Free Software Foundation, Inc.
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))
33 (defmacro luna-find-class (name)
34 "Return the luna-class of the given NAME."
35 `(get ,name 'luna-class))
37 (defmacro luna-set-class (name class)
38 `(put ,name 'luna-class ,class))
40 (defmacro luna-class-obarray (class)
43 (defmacro luna-class-parents (class)
46 (defmacro luna-class-number-of-slots (class)
49 (defmacro luna-define-class (type &optional parents slots)
50 "Define TYPE as a luna-class.
51 If PARENTS is specified, TYPE inherits PARENTS.
52 Each parent must be name of luna-class (symbol).
53 If SLOTS is specified, TYPE will be defined to have them."
54 `(luna-define-class-function ',type ',(append parents '(standard-object))
57 (defun luna-define-class-function (type &optional parents slots)
58 (let ((oa (make-vector 31 0))
64 (setq parent (pop rest)
66 (mapatoms (lambda (sym)
67 (when (setq j (get sym 'luna-slot-index))
68 (setq name (symbol-name sym))
69 (unless (intern-soft name oa)
70 (put (intern name oa) 'luna-slot-index (+ j b))
72 (luna-class-obarray (luna-find-class parent))))
75 (setq name (symbol-name (pop rest)))
76 (unless (intern-soft name oa)
77 (put (intern name oa) 'luna-slot-index i)
79 (luna-set-class type (vector 'class oa parents i))))
81 (defun luna-class-find-member (class member-name)
82 (or (stringp member-name)
83 (setq member-name (symbol-name member-name)))
84 (or (intern-soft member-name (luna-class-obarray class))
85 (let ((parents (luna-class-parents class))
89 (setq ret (luna-class-find-member
90 (luna-find-class (pop parents))
94 (defsubst luna-class-find-or-make-member (class member-name)
95 (or (stringp member-name)
96 (setq member-name (symbol-name member-name)))
97 (intern member-name (luna-class-obarray class)))
99 (defmacro luna-class-slot-index (class slot-name)
100 `(get (luna-class-find-member ,class ,slot-name) 'luna-slot-index))
102 (defmacro luna-define-method (name &rest definition)
103 "Define NAME as a method function of a class.
105 Usage of this macro follows:
107 (luna-define-method NAME [METHOD-QUALIFIER] ARGLIST [DOCSTRING] BODY...)
109 NAME is the name of method.
111 Optional argument METHOD-QUALIFIER must be :before, :after or :around.
112 If it is :before / :after, the method is called before / after a
113 method of parent class is finished. ARGLIST is like an argument list
114 of lambda, but (car ARGLIST) must be specialized parameter. (car (car
115 ARGLIST)) is name of variable and \(nth 1 (car ARGLIST)) is name of
118 Optional argument DOCSTRING is the documentation of method.
120 BODY is the body of method."
121 (let ((method-qualifier (pop definition))
122 args specializer class self)
123 (if (memq method-qualifier '(:before :after :around))
124 (setq args (pop definition))
125 (setq args method-qualifier
126 method-qualifier nil))
127 (setq specializer (car args)
128 class (nth 1 specializer)
129 self (car specializer))
130 `(let ((func (lambda ,(if self
131 (cons self (cdr args))
134 (sym (luna-class-find-or-make-member
135 (luna-find-class ',class) ',name))
136 (cache (get ',name 'luna-method-cache)))
138 (unintern ',class cache))
140 (put sym 'luna-method-qualifier ,method-qualifier))))
142 (put 'luna-define-method 'lisp-indent-function 'defun)
144 (def-edebug-spec luna-define-method
145 (&define name [&optional &or ":before" ":after" ":around"]
148 [&optional ["&optional" arg &rest arg]]
149 &optional ["&rest" arg])
152 (defun luna-class-find-parents-functions (class service)
153 (let ((parents (luna-class-parents class))
157 (setq ret (luna-class-find-functions
158 (luna-find-class (pop parents))
162 (defun luna-class-find-functions (class service)
163 (let ((sym (luna-class-find-member class service)))
165 (cond ((eq (get sym 'luna-method-qualifier) :before)
166 (cons (symbol-function sym)
167 (luna-class-find-parents-functions class service)))
168 ((eq (get sym 'luna-method-qualifier) :after)
169 (nconc (luna-class-find-parents-functions class service)
170 (list (symbol-function sym))))
171 ((eq (get sym 'luna-method-qualifier) :around)
172 (cons sym (luna-class-find-parents-functions class service)))
174 (list (symbol-function sym))))
175 (luna-class-find-parents-functions class service))))
178 ;;; @ instance (entity)
181 (defmacro luna-class-name (entity)
182 "Return class-name of the ENTITY."
185 (defmacro luna-set-class-name (entity name)
186 `(aset ,entity 0 ,name))
188 (defmacro luna-get-obarray (entity)
191 (defmacro luna-set-obarray (entity obarray)
192 `(aset ,entity 1 ,obarray))
194 (defmacro luna-slot-index (entity slot-name)
195 `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
198 (defsubst luna-slot-value (entity slot)
199 "Return the value of SLOT of ENTITY."
200 (aref entity (luna-slot-index entity slot)))
202 (defsubst luna-set-slot-value (entity slot value)
203 "Store VALUE into SLOT of ENTITY."
204 (aset entity (luna-slot-index entity slot) value))
206 (defmacro luna-find-functions (entity service)
207 `(luna-class-find-functions (luna-find-class (luna-class-name ,entity))
210 (defsubst luna-send (entity message &rest luna-current-method-arguments)
211 "Send MESSAGE to ENTITY, and return the result.
212 LUNA-CURRENT-METHOD-ARGUMENTS is arguments of the MESSAGE."
213 (let ((luna-next-methods (luna-find-functions entity message))
215 luna-previous-return-value)
216 (while (and luna-next-methods
218 (setq luna-current-method (pop luna-next-methods)
219 luna-previous-return-value
220 (apply luna-current-method
221 luna-current-method-arguments))
222 (if (symbolp luna-current-method)
223 (not (eq (get luna-current-method
224 'luna-method-qualifier) :around))
226 luna-previous-return-value))
229 (defvar luna-next-methods nil)
230 (defvar luna-current-method-arguments nil))
232 (defun luna-call-next-method ()
233 "Call the next method in a method with :around qualifier."
234 (let (luna-current-method
235 luna-previous-return-value)
236 (while (and luna-next-methods
238 (setq luna-current-method (pop luna-next-methods)
239 luna-previous-return-value
240 (apply luna-current-method
241 luna-current-method-arguments))
242 (if (symbolp luna-current-method)
243 (not (eq (get luna-current-method
244 'luna-method-qualifier) :around))
246 luna-previous-return-value))
248 (defun luna-make-entity (type &rest init-args)
249 "Make instance of luna-class TYPE and return it.
250 If INIT-ARGS is specified, it is used as initial values of the slots.
251 It must be plist and each slot name must have prefix `:'."
252 (let* ((c (get type 'luna-class))
253 (v (make-vector (luna-class-number-of-slots c) nil)))
254 (luna-set-class-name v type)
255 (luna-set-obarray v (make-vector 7 0))
256 (apply #'luna-send v 'initialize-instance v init-args)))
259 ;;; @ interface (generic function)
262 (defun luna-apply-generic (entity message &rest luna-current-method-arguments)
263 (let* ((class (luna-class-name entity))
264 (cache (get message 'luna-method-cache))
265 (sym (intern-soft (symbol-name class) cache))
268 (setq luna-next-methods (symbol-value sym))
269 (setq luna-next-methods
270 (luna-find-functions entity message))
271 (set (intern (symbol-name class) cache)
273 (luna-call-next-method)))
275 (defsubst luna-arglist-to-arguments (arglist)
278 (let ((arg (car arglist)))
279 (or (memq arg '(&optional &rest))
280 (setq dest (cons arg dest))))
281 (setq arglist (cdr arglist)))
284 (defmacro luna-define-generic (name args &optional doc)
285 "Define generic-function NAME.
286 ARGS is argument of and DOC is DOC-string."
289 (defun ,(intern (symbol-name name)) ,args
291 (luna-apply-generic ,(car args) ',name
292 ,@(luna-arglist-to-arguments args)))
293 (put ',name 'luna-method-cache (make-vector 31 0)))
295 (defun ,(intern (symbol-name name)) ,args
296 (luna-apply-generic ,(car args) ',name
297 ,@(luna-arglist-to-arguments args)))
298 (put ',name 'luna-method-cache (make-vector 31 0)))))
300 (put 'luna-define-generic 'lisp-indent-function 'defun)
306 (defun luna-define-internal-accessors (class-name)
307 "Define internal accessors for an entity of CLASS-NAME."
308 (let ((entity-class (luna-find-class class-name))
309 parents parent-class)
312 (if (luna-class-slot-index entity-class slot)
314 (setq parents (luna-class-parents entity-class))
316 (setq parent-class (luna-find-class (car parents)))
317 (if (luna-class-slot-index parent-class slot)
318 (throw 'derived nil))
319 (setq parents (cdr parents)))
322 (defmacro ,(intern (format "%s-%s-internal"
326 ,(luna-class-slot-index entity-class
327 (intern (symbol-name slot)))))
328 (defmacro ,(intern (format "%s-set-%s-internal"
332 ,(luna-class-slot-index
333 entity-class (intern (symbol-name slot)))
335 (luna-class-obarray entity-class))))
338 ;;; @ standard object
341 (luna-define-class-function 'standard-object)
343 (luna-define-method initialize-instance ((entity standard-object)
345 (let* ((c (luna-find-class (luna-class-name entity)))
346 (oa (luna-class-obarray c))
349 (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
352 (aset entity (get s 'luna-slot-index) i)))