source: trunk/j/src/org/armedbear/lisp/defclass.lisp @ 4279

Last change on this file since 4279 was 4279, checked in by piso, 19 years ago

Work in progress.

File size: 8.0 KB
Line 
1;;; defclass.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defclass.lisp,v 1.2 2003-10-10 14:15:43 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
22(defmacro push-on-end (value location)
23  `(setf ,location (nconc ,location (list ,value))))
24
25;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
26;;; which must be non-nil.
27
28(defun (setf getf*) (new-value plist key)
29  (block body
30    (do ((x plist (cddr x)))
31        ((null x))
32      (when (eq (car x) key)
33        (setf (car (cdr x)) new-value)
34        (return-from body new-value)))
35    (push-on-end key plist)
36    (push-on-end new-value plist)
37    new-value))
38
39(defun mapappend (fun &rest args)
40  (if (some #'null args)
41      ()
42      (append (apply fun (mapcar #'car args))
43              (apply #'mapappend fun (mapcar #'cdr args)))))
44
45(defun mapplist (fun x)
46  (if (null x)
47      ()
48      (cons (funcall fun (car x) (cadr x))
49            (mapplist fun (cddr x)))))
50
51(defsetf class-name %set-class-name)
52
53(defun canonicalize-direct-slots (direct-slots)
54  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
55
56(defun canonicalize-direct-slot (spec)
57  (if (symbolp spec)
58      `(list :name ',spec)
59      (let ((name (car spec))
60            (initfunction nil)
61            (initform nil)
62            (initargs ())
63            (readers ())
64            (writers ())
65            (other-options ()))
66        (do ((olist (cdr spec) (cddr olist)))
67            ((null olist))
68          (case (car olist)
69            (:initform
70             (setq initfunction
71                   `(function (lambda () ,(cadr olist))))
72             (setq initform `',(cadr olist)))
73            (:initarg
74             (push-on-end (cadr olist) initargs))
75            (:reader
76             (push-on-end (cadr olist) readers))
77            (:writer
78             (push-on-end (cadr olist) writers))
79            (:accessor
80             (push-on-end (cadr olist) readers)
81             (push-on-end `(setf ,(cadr olist)) writers))
82            (otherwise
83             (push-on-end `',(car olist) other-options)
84             (push-on-end `',(cadr olist) other-options))))
85        `(list
86          :name ',name
87          ,@(when initfunction
88              `(:initform ,initform
89                          :initfunction ,initfunction))
90          ,@(when initargs `(:initargs ',initargs))
91          ,@(when readers `(:readers ',readers))
92          ,@(when writers `(:writers ',writers))
93          ,@other-options))))
94
95(defun canonicalize-direct-superclasses (direct-superclasses)
96  `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses)))
97
98(defun canonicalize-direct-superclass (class-name)
99  `(find-class ',class-name))
100
101(defun canonicalize-defclass-options (options)
102  (mapappend #'canonicalize-defclass-option options))
103
104(defun canonicalize-defclass-option (option)
105  (case (car option)
106    (:metaclass
107     (list ':metaclass
108           `(find-class ',(cadr option))))
109    (:default-initargs
110     (list
111      ':direct-default-initargs
112      `(list ,@(mapappend
113                #'(lambda (x) x)
114                (mapplist
115                 #'(lambda (key value)
116                    `(',key ,value))
117                 (cdr option))))))
118    (t (list `',(car option) `',(cadr option)))))
119
120;;; Slot definition metaobjects
121
122;;; N.B. Quietly retain all unknown slot options (rather than signaling an
123;;; error), so that it's easy to add new ones.
124
125(defun make-direct-slot-definition
126  (&rest properties
127         &key name (initargs ()) (initform nil) (initfunction nil)
128         (readers ()) (writers ()) (allocation :instance)
129         &allow-other-keys)
130  (let ((slot (copy-list properties))) ; Don't want to side effect &rest list
131    (setf (getf* slot ':name) name)
132    (setf (getf* slot ':initargs) initargs)
133    (setf (getf* slot ':initform) initform)
134    (setf (getf* slot ':initfunction) initfunction)
135    (setf (getf* slot ':readers) readers)
136    (setf (getf* slot ':writers) writers)
137    (setf (getf* slot ':allocation) allocation)
138    slot))
139
140(defun make-effective-slot-definition
141  (&rest properties
142         &key name (initargs ()) (initform nil) (initfunction nil)
143         (allocation :instance)
144         &allow-other-keys)
145  (let ((slot (copy-list properties)))  ; Don't want to side effect &rest list
146    (setf (getf* slot ':name) name)
147    (setf (getf* slot ':initargs) initargs)
148    (setf (getf* slot ':initform) initform)
149    (setf (getf* slot ':initfunction) initfunction)
150    (setf (getf* slot ':allocation) allocation)
151    slot))
152
153(defun slot-definition-name (slot)
154  (getf slot ':name))
155(defun (setf slot-definition-name) (new-value slot)
156  (setf (getf* slot ':name) new-value))
157
158(defun slot-definition-initfunction (slot)
159  (getf slot ':initfunction))
160(defun (setf slot-definition-initfunction) (new-value slot)
161  (setf (getf* slot ':initfunction) new-value))
162
163(defun slot-definition-initform (slot)
164  (getf slot ':initform))
165(defun (setf slot-definition-initform) (new-value slot)
166  (setf (getf* slot ':initform) new-value))
167
168(defun slot-definition-initargs (slot)
169  (getf slot ':initargs))
170(defun (setf slot-definition-initargs) (new-value slot)
171  (setf (getf* slot ':initargs) new-value))
172
173(defun slot-definition-readers (slot)
174  (getf slot ':readers))
175(defun (setf slot-definition-readers) (new-value slot)
176  (setf (getf* slot ':readers) new-value))
177
178(defun slot-definition-writers (slot)
179  (getf slot ':writers))
180(defun (setf slot-definition-writers) (new-value slot)
181  (setf (getf* slot ':writers) new-value))
182
183(defun slot-definition-allocation (slot)
184  (getf slot ':allocation))
185(defun (setf slot-definition-allocation) (new-value slot)
186  (setf (getf* slot ':allocation) new-value))
187
188;;; Simple vectors are used for slot storage.
189
190(defun allocate-slot-storage (size initial-value)
191  (make-array size :initial-element initial-value))
192
193;;; Standard instance allocation
194
195(defparameter secret-unbound-value (list "slot unbound"))
196
197(defun instance-slot-p (slot)
198  (eq (slot-definition-allocation slot) ':instance))
199
200(defun std-allocate-instance (class)
201  (allocate-std-instance
202   class
203   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
204                          secret-unbound-value)))
205
206(defun make-instance-standard-class
207  (metaclass &key name direct-superclasses direct-slots
208             &allow-other-keys)
209  (declare (ignore metaclass))
210  (let ((class (std-allocate-instance (find-class 'standard-class))))
211    (setf (class-name class) name)
212;;     (setf (class-direct-subclasses class) ())
213;;     (setf (class-direct-methods class) ())
214    (std-after-initialization-for-classes class
215                                          :direct-slots direct-slots
216                                          :direct-superclasses direct-superclasses)
217    class))
218
219;; FIXME
220(defun std-after-initialization-for-classes (&rest args) )
221
222(defun ensure-class (name &rest all-keys &allow-other-keys)
223  (let ((class (find-class name nil)))
224    (unless class
225      (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
226      (add-class class))
227    class))
228
229(defmacro defclass (name direct-superclasses direct-slots
230                         &rest options)
231  `(ensure-class ',name
232                 :direct-superclasses
233                 ,(canonicalize-direct-superclasses direct-superclasses)
234                 :direct-slots
235                 ,(canonicalize-direct-slots direct-slots)
236                 ,@(canonicalize-defclass-options options)))
Note: See TracBrowser for help on using the repository browser.