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

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

ALLOCATE-INSTANCE

File size: 15.7 KB
Line 
1;;; defclass.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defclass.lisp,v 1.4 2003-10-10 17:17:24 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(defsetf class-direct-superclasses %set-class-direct-superclasses)
53(defsetf class-direct-subclasses %set-class-direct-subclasses)
54(defsetf class-direct-methods %set-class-direct-methods)
55(defsetf class-direct-slots %set-class-direct-slots)
56(defsetf class-precedence-list %set-class-precedence-list)
57(defsetf class-slots %set-class-slots)
58
59(defun canonicalize-direct-slots (direct-slots)
60  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
61
62(defun canonicalize-direct-slot (spec)
63  (if (symbolp spec)
64      `(list :name ',spec)
65      (let ((name (car spec))
66            (initfunction nil)
67            (initform nil)
68            (initargs ())
69            (readers ())
70            (writers ())
71            (other-options ()))
72        (do ((olist (cdr spec) (cddr olist)))
73            ((null olist))
74          (case (car olist)
75            (:initform
76             (setq initfunction
77                   `(function (lambda () ,(cadr olist))))
78             (setq initform `',(cadr olist)))
79            (:initarg
80             (push-on-end (cadr olist) initargs))
81            (:reader
82             (push-on-end (cadr olist) readers))
83            (:writer
84             (push-on-end (cadr olist) writers))
85            (:accessor
86             (push-on-end (cadr olist) readers)
87             (push-on-end `(setf ,(cadr olist)) writers))
88            (otherwise
89             (push-on-end `',(car olist) other-options)
90             (push-on-end `',(cadr olist) other-options))))
91        `(list
92          :name ',name
93          ,@(when initfunction
94              `(:initform ,initform
95                          :initfunction ,initfunction))
96          ,@(when initargs `(:initargs ',initargs))
97          ,@(when readers `(:readers ',readers))
98          ,@(when writers `(:writers ',writers))
99          ,@other-options))))
100
101(defun canonicalize-direct-superclasses (direct-superclasses)
102  `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses)))
103
104(defun canonicalize-direct-superclass (class-name)
105  `(find-class ',class-name))
106
107(defun canonicalize-defclass-options (options)
108  (mapappend #'canonicalize-defclass-option options))
109
110(defun canonicalize-defclass-option (option)
111  (case (car option)
112    (:metaclass
113     (list ':metaclass
114           `(find-class ',(cadr option))))
115    (:default-initargs
116     (list
117      ':direct-default-initargs
118      `(list ,@(mapappend
119                #'(lambda (x) x)
120                (mapplist
121                 #'(lambda (key value)
122                    `(',key ,value))
123                 (cdr option))))))
124    (t (list `',(car option) `',(cadr option)))))
125
126;;; Slot definition metaobjects
127
128;;; N.B. Quietly retain all unknown slot options (rather than signaling an
129;;; error), so that it's easy to add new ones.
130
131(defun make-direct-slot-definition
132  (&rest properties
133         &key name (initargs ()) (initform nil) (initfunction nil)
134         (readers ()) (writers ()) (allocation :instance)
135         &allow-other-keys)
136  (let ((slot (copy-list properties))) ; Don't want to side effect &rest list
137    (setf (getf* slot ':name) name)
138    (setf (getf* slot ':initargs) initargs)
139    (setf (getf* slot ':initform) initform)
140    (setf (getf* slot ':initfunction) initfunction)
141    (setf (getf* slot ':readers) readers)
142    (setf (getf* slot ':writers) writers)
143    (setf (getf* slot ':allocation) allocation)
144    slot))
145
146(defun make-effective-slot-definition
147  (&rest properties
148         &key name (initargs ()) (initform nil) (initfunction nil)
149         (allocation :instance)
150         &allow-other-keys)
151  (let ((slot (copy-list properties)))  ; Don't want to side effect &rest list
152    (setf (getf* slot ':name) name)
153    (setf (getf* slot ':initargs) initargs)
154    (setf (getf* slot ':initform) initform)
155    (setf (getf* slot ':initfunction) initfunction)
156    (setf (getf* slot ':allocation) allocation)
157    slot))
158
159(defun slot-definition-name (slot)
160  (getf slot ':name))
161(defun (setf slot-definition-name) (new-value slot)
162  (setf (getf* slot ':name) new-value))
163
164(defun slot-definition-initfunction (slot)
165  (getf slot ':initfunction))
166(defun (setf slot-definition-initfunction) (new-value slot)
167  (setf (getf* slot ':initfunction) new-value))
168
169(defun slot-definition-initform (slot)
170  (getf slot ':initform))
171(defun (setf slot-definition-initform) (new-value slot)
172  (setf (getf* slot ':initform) new-value))
173
174(defun slot-definition-initargs (slot)
175  (getf slot ':initargs))
176(defun (setf slot-definition-initargs) (new-value slot)
177  (setf (getf* slot ':initargs) new-value))
178
179(defun slot-definition-readers (slot)
180  (getf slot ':readers))
181(defun (setf slot-definition-readers) (new-value slot)
182  (setf (getf* slot ':readers) new-value))
183
184(defun slot-definition-writers (slot)
185  (getf slot ':writers))
186(defun (setf slot-definition-writers) (new-value slot)
187  (setf (getf* slot ':writers) new-value))
188
189(defun slot-definition-allocation (slot)
190  (getf slot ':allocation))
191(defun (setf slot-definition-allocation) (new-value slot)
192  (setf (getf* slot ':allocation) new-value))
193
194;;; finalize-inheritance
195
196(defun std-finalize-inheritance (class)
197  (setf (class-precedence-list class)
198        (funcall (if (eq (class-of class) the-class-standard-class)
199                     #'std-compute-class-precedence-list
200                     #'compute-class-precedence-list)
201                 class))
202  (setf (class-slots class)
203        (funcall (if (eq (class-of class) the-class-standard-class)
204                     #'std-compute-slots
205                     #'compute-slots)
206                 class))
207  (values))
208
209;;; Class precedence lists
210
211(defun std-compute-class-precedence-list (class)
212  (let ((classes-to-order (collect-superclasses* class)))
213    (topological-sort classes-to-order
214                      (remove-duplicates
215                       (mapappend #'local-precedence-ordering
216                                  classes-to-order))
217                      #'std-tie-breaker-rule)))
218
219;;; topological-sort implements the standard algorithm for topologically
220;;; sorting an arbitrary set of elements while honoring the precedence
221;;; constraints given by a set of (X,Y) pairs that indicate that element
222;;; X must precede element Y.  The tie-breaker procedure is called when it
223;;; is necessary to choose from multiple minimal elements; both a list of
224;;; candidates and the ordering so far are provided as arguments.
225
226(defun topological-sort (elements constraints tie-breaker)
227  (let ((remaining-constraints constraints)
228        (remaining-elements elements)
229        (result ()))
230    (loop
231      (let ((minimal-elements
232             (remove-if
233              #'(lambda (class)
234                 (member class remaining-constraints
235                         :key #'cadr))
236              remaining-elements)))
237        (when (null minimal-elements)
238          (if (null remaining-elements)
239              (return-from topological-sort result)
240              (error "Inconsistent precedence graph.")))
241        (let ((choice (if (null (cdr minimal-elements))
242                          (car minimal-elements)
243                          (funcall tie-breaker
244                                   minimal-elements
245                                   result))))
246          (setq result (append result (list choice)))
247          (setq remaining-elements
248                (remove choice remaining-elements))
249          (setq remaining-constraints
250                (remove choice
251                        remaining-constraints
252                        :test #'member)))))))
253
254;;; In the event of a tie while topologically sorting class precedence lists,
255;;; the CLOS Specification says to "select the one that has a direct subclass
256;;; rightmost in the class precedence list computed so far."  The same result
257;;; is obtained by inspecting the partially constructed class precedence list
258;;; from right to left, looking for the first minimal element to show up among
259;;; the direct superclasses of the class precedence list constituent.
260;;; (There's a lemma that shows that this rule yields a unique result.)
261
262(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
263  (dolist (cpl-constituent (reverse cpl-so-far))
264    (let* ((supers (class-direct-superclasses cpl-constituent))
265           (common (intersection minimal-elements supers)))
266      (when (not (null common))
267        (return-from std-tie-breaker-rule (car common))))))
268
269;;; This version of collect-superclasses* isn't bothered by cycles in the class
270;;; hierarchy, which sometimes happen by accident.
271
272(defun collect-superclasses* (class)
273  (labels ((all-superclasses-loop (seen superclasses)
274                                  (let ((to-be-processed
275                                         (set-difference superclasses seen)))
276                                    (if (null to-be-processed)
277                                        superclasses
278                                        (let ((class-to-process
279                                               (car to-be-processed)))
280                                          (all-superclasses-loop
281                                           (cons class-to-process seen)
282                                           (union (class-direct-superclasses
283                                                   class-to-process)
284                                                  superclasses)))))))
285          (all-superclasses-loop () (list class))))
286
287;;; The local precedence ordering of a class C with direct superclasses C_1,
288;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
289
290(defun local-precedence-ordering (class)
291  (mapcar #'list
292          (cons class
293                (butlast (class-direct-superclasses class)))
294          (class-direct-superclasses class)))
295
296;;; Slot inheritance
297
298(defun std-compute-slots (class)
299  (let* ((all-slots (mapappend #'class-direct-slots
300                               (class-precedence-list class)))
301         (all-names (remove-duplicates
302                     (mapcar #'slot-definition-name all-slots))))
303    (mapcar #'(lambda (name)
304               (funcall
305                (if (eq (class-of class) the-class-standard-class)
306                    #'std-compute-effective-slot-definition
307                    #'compute-effective-slot-definition)
308                class
309                (remove name all-slots
310                        :key #'slot-definition-name
311                        :test-not #'eq)))
312            all-names)))
313
314(defun std-compute-effective-slot-definition (class direct-slots)
315  (declare (ignore class))
316  (let ((initer (find-if-not #'null direct-slots
317                             :key #'slot-definition-initfunction)))
318    (make-effective-slot-definition
319     :name (slot-definition-name (car direct-slots))
320     :initform (if initer
321                   (slot-definition-initform initer)
322                   nil)
323     :initfunction (if initer
324                       (slot-definition-initfunction initer)
325                       nil)
326     :initargs (remove-duplicates
327                (mapappend #'slot-definition-initargs
328                           direct-slots))
329     :allocation (slot-definition-allocation (car direct-slots)))))
330
331;;; Simple vectors are used for slot storage.
332
333(defun allocate-slot-storage (size initial-value)
334  (make-array size :initial-element initial-value))
335
336;;; Standard instance allocation
337
338(defvar the-class-standard-class (find-class 'standard-class))
339
340(defparameter secret-unbound-value (list "slot unbound"))
341
342(defun instance-slot-p (slot)
343  (eq (slot-definition-allocation slot) ':instance))
344
345(defun std-allocate-instance (class)
346  (allocate-std-instance
347   class
348   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
349                          secret-unbound-value)))
350
351(defun allocate-instance (class)
352  (std-allocate-instance class))
353
354(defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots
355                                               &allow-other-keys)
356  (declare (ignore metaclass))
357;;   (format t "name = ~S~%" name)
358;;   (format t "direct-superclasses = ~S~%" direct-superclasses)
359;;   (format t "direct-slots = ~S~%" direct-slots)
360  (let ((class (std-allocate-instance (find-class 'standard-class))))
361    (setf (class-name class) name)
362    (setf (class-direct-subclasses class) ())
363    (setf (class-direct-methods class) ())
364    (std-after-initialization-for-classes class
365                                          :direct-slots direct-slots
366                                          :direct-superclasses direct-superclasses)
367    class))
368
369;; FIXME
370(defun std-after-initialization-for-classes (class
371                                             &key direct-superclasses direct-slots
372                                             &allow-other-keys)
373  (let ((supers
374         (or direct-superclasses
375             (list (find-class 'standard-object)))))
376    (setf (class-direct-superclasses class) supers)
377    (dolist (superclass supers)
378      (push class (class-direct-subclasses superclass))))
379  (let ((slots
380         (mapcar #'(lambda (slot-properties)
381                    (apply #'make-direct-slot-definition
382                           slot-properties))
383                 direct-slots)))
384    (setf (class-direct-slots class) slots)
385;;     (dolist (direct-slot slots)
386;;       (dolist (reader (slot-definition-readers direct-slot))
387;;         (add-reader-method
388;;          class reader (slot-definition-name direct-slot)))
389;;       (dolist (writer (slot-definition-writers direct-slot))
390;;         (add-writer-method
391;;          class writer (slot-definition-name direct-slot))))
392    )
393  (funcall (if (eq (class-of class) (find-class 'standard-class))
394               #'std-finalize-inheritance
395               #'finalize-inheritance)
396           class)
397  (values))
398
399(defun ensure-class (name &rest all-keys &allow-other-keys)
400  (let ((class (find-class name nil)))
401    (unless class
402      (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
403      (add-class class))
404    class))
405
406(defmacro defclass (name direct-superclasses direct-slots
407                         &rest options)
408  `(ensure-class ',name
409                 :direct-superclasses
410                 ,(canonicalize-direct-superclasses direct-superclasses)
411                 :direct-slots
412                 ,(canonicalize-direct-slots direct-slots)
413                 ,@(canonicalize-defclass-options options)))
Note: See TracBrowser for help on using the repository browser.