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 (defmacro luna-find-class (name)
28 "Return the luna-class of the given NAME."
29 `(get ,name 'luna-class))
31 (defmacro luna-set-class (name class)
32 `(put ,name 'luna-class ,class))
34 (defmacro luna-class-obarray (class)
37 (defmacro luna-class-number-of-slots (class)
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))
50 (setq parent (pop rest))
51 (mapatoms (lambda (sym)
52 (setq name (symbol-name sym))
53 (unless (intern-soft name oa)
54 (put (intern name oa) 'luna-member-index i)
57 (luna-class-obarray parent))
61 (setq name (symbol-name (pop rest)))
62 (unless (intern-soft name oa)
63 (put (intern name oa) 'luna-member-index i)
66 `(luna-set-class ',type
67 (vector 'class ,oa ,parents ,i))
70 (defmacro luna-class-name (entity)
71 "Return class-name of the ENTITY."
74 (defmacro luna-set-class-name (entity name)
75 `(aset ,entity 0 ,name))
77 (defmacro luna-get-obarray (entity)
80 (defmacro luna-set-obarray (entity obarray)
81 `(aset ,entity 1 ,obarray))
83 (defmacro luna-make-entity (type &rest init-args)
84 "Make instance of luna-class TYPE and return it.
85 If INIT-ARGS is specified, it is used as initial values of the slots.
86 It must be plist and each slot name must have prefix `:'."
87 `(apply #'luna-make-entity-function ',type ',init-args))
89 (defsubst luna-make-entity-function (type &rest init-args)
90 (let* ((c (get type 'luna-class))
91 (v (make-vector (luna-class-number-of-slots c) nil))
92 (oa (luna-class-obarray c))
94 (luna-set-class-name v type)
95 (luna-set-obarray v (make-vector 7 0))
97 (setq s (intern-soft (substring (symbol-name (pop init-args)) 1) oa)
100 (aset v (get s 'luna-member-index) i)
104 (defsubst luna-class-find-member (class member-name)
105 (or (stringp member-name)
106 (setq member-name (symbol-name member-name)))
107 (intern-soft member-name (luna-class-obarray class)))
109 (defsubst luna-class-find-or-make-member (class member-name)
110 (or (stringp member-name)
111 (setq member-name (symbol-name member-name)))
112 (intern member-name (luna-class-obarray class)))
114 (defmacro luna-class-slot-index (class slot-name)
115 `(get (luna-class-find-member ,class ,slot-name) 'luna-member-index))
117 (defmacro luna-slot-index (entity slot-name)
118 `(luna-class-slot-index (luna-find-class (luna-class-name ,entity))
121 (defsubst luna-slot-value (entity slot-name)
122 "Return value of SLOT-NAME of ENTITY."
123 (aref entity (luna-slot-index entity slot-name)))
125 (defmacro luna-define-method (name args &rest body)
126 "Define NAME as a method function of (nth 1 (car ARGS)) backend.
128 ARGS is like an argument list of lambda, but (car ARGS) must be
129 specialized parameter. (car (car ARGS)) is name of variable and (nth
130 1 (car ARGS)) is name of backend."
131 (let* ((specializer (car args))
132 (class (nth 1 specializer))
133 (self (car specializer)))
134 `(let ((func (lambda ,(if self
135 (cons self (cdr args))
138 (fset (luna-class-find-or-make-member (luna-find-class ',class) ',name)
141 (put 'luna-define-method 'lisp-indent-function 'defun)
143 (defmacro luna-class-find-function (class service)
144 `(symbol-function (luna-class-find-member ,class ,service)))
146 (defmacro luna-find-function (entity service)
147 `(luna-class-find-function (luna-find-class (luna-class-name ,entity))
150 (defsubst luna-send (entity message &rest args)
151 "Send MESSAGE to ENTITY with ARGS, and return the result."
152 (apply (luna-find-function entity message)
155 (defsubst luna-arglist-to-arguments (arglist)
158 (let ((arg (car arglist)))
159 (or (memq arg '(&optional &rest))
160 (setq dest (cons arg dest)))
162 (setq arglist (cdr arglist)))
165 (defmacro luna-define-generic (name args &optional doc)
166 "Define generic-function NAME.
167 ARGS is argument of and DOC is DOC-string."
169 `(defun ,(intern (symbol-name name)) ,args
171 (luna-send ,(car args) ',name
172 ,@(luna-arglist-to-arguments (cdr args)))
174 `(defun ,(intern (symbol-name name)) ,args
175 (luna-send ,(car args) ',name
176 ,@(luna-arglist-to-arguments (cdr args)))
179 (put 'luna-define-generic 'lisp-indent-function 'defun)