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

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

Work in progress.

File size: 19.3 KB
Line 
1;;; defclass.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: defclass.lisp,v 1.5 2003-10-10 23:35:08 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 slot access
337
338;;; N.B. The location of the effective-slots slots in the class metaobject for
339;;; standard-class must be determined without making any further slot
340;;; references.
341
342(defvar the-slots-of-standard-class) ;standard-class's class-slots
343(defvar the-class-standard-class)    ;standard-class's class metaobject
344
345(defun slot-location (class slot-name)
346  (if (and (eq slot-name 'effective-slots)
347           (eq class the-class-standard-class))
348      (position 'effective-slots the-slots-of-standard-class
349                :key #'slot-definition-name)
350      (let ((slot (find slot-name
351                        (class-slots class)
352                        :key #'slot-definition-name)))
353        (if (null slot)
354            (error "The slot ~S is missing from the class ~S."
355                   slot-name class)
356            (let ((pos (position slot
357                                 (remove-if-not #'instance-slot-p
358                                                (class-slots class)))))
359              (if (null pos)
360                  (error "The slot ~S is not an instance~@
361                  slot in the class ~S."
362                         slot-name class)
363                  pos))))))
364
365(defun slot-contents (slots location)
366  (svref slots location))
367
368(defun (setf slot-contents) (new-value slots location)
369  (setf (svref slots location) new-value))
370
371(defun std-slot-value (instance slot-name)
372  (let* ((location (slot-location (class-of instance) slot-name))
373         (slots (std-instance-slots instance))
374         (val (slot-contents slots location)))
375    (if (eq secret-unbound-value val)
376        (error "The slot ~S is unbound in the object ~S."
377               slot-name instance)
378        val)))
379(defun slot-value (object slot-name)
380  (if (eq (class-of (class-of object)) the-class-standard-class)
381      (std-slot-value object slot-name)
382      (slot-value-using-class (class-of object) object slot-name)))
383
384(defun (setf std-slot-value) (new-value instance slot-name)
385  (let ((location (slot-location (class-of instance) slot-name))
386        (slots (std-instance-slots instance)))
387    (setf (slot-contents slots location) new-value)))
388(defun (setf slot-value) (new-value object slot-name)
389  (if (eq (class-of (class-of object)) the-class-standard-class)
390      (setf (std-slot-value object slot-name) new-value)
391      (setf-slot-value-using-class
392       new-value (class-of object) object slot-name)))
393
394(defun std-slot-boundp (instance slot-name)
395  (let ((location (slot-location (class-of instance) slot-name))
396        (slots (std-instance-slots instance)))
397    (not (eq secret-unbound-value (slot-contents slots location)))))
398(defun slot-boundp (object slot-name)
399  (if (eq (class-of (class-of object)) the-class-standard-class)
400      (std-slot-boundp object slot-name)
401      (slot-boundp-using-class (class-of object) object slot-name)))
402
403(defun std-slot-makunbound (instance slot-name)
404  (let ((location (slot-location (class-of instance) slot-name))
405        (slots (std-instance-slots instance)))
406    (setf (slot-contents slots location) secret-unbound-value))
407  instance)
408(defun slot-makunbound (object slot-name)
409  (if (eq (class-of (class-of object)) the-class-standard-class)
410      (std-slot-makunbound object slot-name)
411      (slot-makunbound-using-class (class-of object) object slot-name)))
412
413(defun std-slot-exists-p (instance slot-name)
414  (not (null (find slot-name (class-slots (class-of instance))
415                   :key #'slot-definition-name))))
416(defun slot-exists-p (object slot-name)
417  (if (eq (class-of (class-of object)) the-class-standard-class)
418      (std-slot-exists-p object slot-name)
419      (slot-exists-p-using-class (class-of object) object slot-name)))
420
421;;; Standard instance allocation
422
423(defvar the-class-standard-class (find-class 'standard-class))
424
425(defparameter secret-unbound-value (list "slot unbound"))
426
427(defun instance-slot-p (slot)
428  (eq (slot-definition-allocation slot) ':instance))
429
430(defun std-allocate-instance (class)
431  (allocate-std-instance
432   class
433   (allocate-slot-storage (count-if #'instance-slot-p (class-slots class))
434                          secret-unbound-value)))
435
436(defun allocate-instance (class)
437  (std-allocate-instance class))
438
439(defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots
440                                               &allow-other-keys)
441  (declare (ignore metaclass))
442;;   (format t "name = ~S~%" name)
443;;   (format t "direct-superclasses = ~S~%" direct-superclasses)
444;;   (format t "direct-slots = ~S~%" direct-slots)
445  (let ((class (std-allocate-instance (find-class 'standard-class))))
446    (setf (class-name class) name)
447    (setf (class-direct-subclasses class) ())
448    (setf (class-direct-methods class) ())
449    (std-after-initialization-for-classes class
450                                          :direct-slots direct-slots
451                                          :direct-superclasses direct-superclasses)
452    class))
453
454;; FIXME
455(defun std-after-initialization-for-classes (class
456                                             &key direct-superclasses direct-slots
457                                             &allow-other-keys)
458  (let ((supers
459         (or direct-superclasses
460             (list (find-class 'standard-object)))))
461    (setf (class-direct-superclasses class) supers)
462    (dolist (superclass supers)
463      (push class (class-direct-subclasses superclass))))
464  (let ((slots
465         (mapcar #'(lambda (slot-properties)
466                    (apply #'make-direct-slot-definition
467                           slot-properties))
468                 direct-slots)))
469    (setf (class-direct-slots class) slots)
470;;     (dolist (direct-slot slots)
471;;       (dolist (reader (slot-definition-readers direct-slot))
472;;         (add-reader-method
473;;          class reader (slot-definition-name direct-slot)))
474;;       (dolist (writer (slot-definition-writers direct-slot))
475;;         (add-writer-method
476;;          class writer (slot-definition-name direct-slot))))
477    )
478  (funcall (if (eq (class-of class) (find-class 'standard-class))
479               #'std-finalize-inheritance
480               #'finalize-inheritance)
481           class)
482  (values))
483
484(defun ensure-class (name &rest all-keys &allow-other-keys)
485  (let ((class (find-class name nil)))
486    (unless class
487      (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys))
488      (add-class class))
489    class))
490
491(defmacro defclass (name direct-superclasses direct-slots
492                         &rest options)
493  `(ensure-class ',name
494                 :direct-superclasses
495                 ,(canonicalize-direct-superclasses direct-superclasses)
496                 :direct-slots
497                 ,(canonicalize-direct-slots direct-slots)
498                 ,@(canonicalize-defclass-options options)))
Note: See TracBrowser for help on using the repository browser.