/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Contents of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (hide annotations)
Sat Apr 26 21:24:06 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
CVS Tags: remove_negative_zero_not_zero
Changes since 1.55: +29 -11 lines
	ANSI test CLASS-0211B.1.  Initforms of shared slots inherited
	from superclasses.

	* src/pcl/std-class.lisp (update-shared-slot-values): New function.
	(update-class): Call it.
	(shared-initialize): Slightly rewritten.
1 wlott 1.1 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27 pw 1.25
28 dtc 1.18 (ext:file-comment
29 gerd 1.56 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.56 2003/04/26 21:24:06 gerd Exp $")
30 wlott 1.1
31 phg 1.7 (in-package :pcl)
32 wlott 1.1
33 ram 1.4 (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
34     (ecase type
35     (reader (slot-definition-reader-function slotd))
36     (writer (slot-definition-writer-function slotd))
37     (boundp (slot-definition-boundp-function slotd))))
38 wlott 1.1
39 ram 1.6 (defmethod (setf slot-accessor-function) (function
40     (slotd effective-slot-definition) type)
41 ram 1.4 (ecase type
42 ram 1.6 (reader (setf (slot-definition-reader-function slotd) function))
43     (writer (setf (slot-definition-writer-function slotd) function))
44 ram 1.4 (boundp (setf (slot-definition-boundp-function slotd) function))))
45    
46     (defconstant *slotd-reader-function-std-p* 1)
47     (defconstant *slotd-writer-function-std-p* 2)
48     (defconstant *slotd-boundp-function-std-p* 4)
49 ram 1.6 (defconstant *slotd-all-function-std-p* 7)
50 ram 1.4
51     (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
52     (let ((flags (slot-value slotd 'accessor-flags)))
53 ram 1.6 (declare (type fixnum flags))
54 ram 1.4 (if (eq type 'all)
55 ram 1.6 (eql *slotd-all-function-std-p* flags)
56 ram 1.4 (let ((mask (ecase type
57     (reader *slotd-reader-function-std-p*)
58     (writer *slotd-writer-function-std-p*)
59     (boundp *slotd-boundp-function-std-p*))))
60 ram 1.6 (declare (type fixnum mask))
61     (not (zerop (the fixnum (logand mask flags))))))))
62 ram 1.4
63     (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
64     (let ((mask (ecase type
65     (reader *slotd-reader-function-std-p*)
66     (writer *slotd-writer-function-std-p*)
67     (boundp *slotd-boundp-function-std-p*)))
68     (flags (slot-value slotd 'accessor-flags)))
69 ram 1.6 (declare (type fixnum mask flags))
70 ram 1.4 (setf (slot-value slotd 'accessor-flags)
71     (if value
72 ram 1.6 (the fixnum (logior mask flags))
73     (the fixnum (logand (the fixnum (lognot mask)) flags)))))
74 ram 1.4 value)
75    
76     (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
77     (let* ((name (slot-value slotd 'name))
78 ram 1.6 (class (slot-value slotd 'class)))
79 ram 1.4 (let ((table (or (gethash name *name->class->slotd-table*)
80     (setf (gethash name *name->class->slotd-table*)
81     (make-hash-table :test 'eq :size 5)))))
82     (setf (gethash class table) slotd))
83     (dolist (type '(reader writer boundp))
84 ram 1.6 (let* ((gf-name (ecase type
85     (reader 'slot-value-using-class)
86     (writer '(setf slot-value-using-class))
87     (boundp 'slot-boundp-using-class)))
88     (gf (gdefinition gf-name)))
89     (compute-slot-accessor-info slotd type gf)))
90     (initialize-internal-slot-gfs name)))
91 ram 1.4
92 gerd 1.54 ;;;
93     ;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
94     ;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
95     ;;; writing/testing effective slot SLOTD.
96     ;;;
97     ;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
98     ;;; GF. Store the effective method in the effective slot definition
99     ;;; object itself; these GFs have special dispatch functions calling
100     ;;; effective methods directly retrieved from effective slot
101     ;;; definition objects, as an optimization.
102     ;;;
103     ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
104     ;;; or some such.
105     ;;;
106 gerd 1.44 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
107     type gf)
108 ram 1.6 (let* ((name (slot-value slotd 'name))
109     (class (slot-value slotd 'class))
110     (old-slotd (find-slot-definition class name))
111     (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
112     (multiple-value-bind (function std-p)
113     (if (eq *boot-state* 'complete)
114     (get-accessor-method-function gf type class slotd)
115     (get-optimized-std-accessor-method-function class slotd type))
116     (setf (slot-accessor-std-p slotd type) std-p)
117     (setf (slot-accessor-function slotd type) function))
118 gerd 1.44 (when (and old-slotd
119     (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
120     (record-pv-update-info slotd))))
121 ram 1.5
122 ram 1.6 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
123     :instance)
124 ram 1.5
125 ram 1.6
126 ram 1.5
127 ram 1.6 (defmethod shared-initialize :after ((object documentation-mixin)
128     slot-names
129     &key (documentation nil documentation-p))
130     (declare (ignore slot-names))
131     (when documentation-p
132 gerd 1.43 (setf (documentation object nil) documentation)))
133 ram 1.5
134 dtc 1.11 (defmethod documentation (object doc-type)
135 dtc 1.10 (declare (ignore object doc-type))
136     nil)
137 wlott 1.1
138 dtc 1.11 (defmethod (setf documentation) (new-value object doc-type)
139 wlott 1.1 (declare (ignore new-value doc-type))
140 gerd 1.44 (error "~@<Can't change the documentation of ~S.~@:>" object))
141 wlott 1.1
142 dtc 1.11 (defmethod documentation ((object documentation-mixin) doc-type)
143 ram 1.6 (declare (ignore doc-type))
144     (plist-value object 'documentation))
145 wlott 1.1
146 dtc 1.11 (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type)
147 ram 1.6 (declare (ignore doc-type))
148     (setf (plist-value object 'documentation) new-value))
149 wlott 1.1
150 dtc 1.11 (defmethod documentation ((slotd standard-slot-definition) doc-type)
151 ram 1.6 (declare (ignore doc-type))
152     (slot-value slotd 'documentation))
153 wlott 1.1
154 dtc 1.11 (defmethod (setf documentation) (new-value (slotd standard-slot-definition) doc-type)
155 ram 1.6 (declare (ignore doc-type))
156     (setf (slot-value slotd 'documentation) new-value))
157 gerd 1.43
158     (defmethod (setf documentation) (doc (gf generic-function) type)
159     (declare (ignore type))
160     (setf (ext:info function documentation (generic-function-name gf))
161     doc))
162 wlott 1.1
163    
164     ;;;
165     ;;; Various class accessors that are a little more complicated than can be
166     ;;; done with automatically generated reader methods.
167     ;;;
168     (defmethod class-prototype ((class std-class))
169     (with-slots (prototype) class
170 ram 1.6 (or prototype (setq prototype (allocate-instance class)))))
171 wlott 1.1
172 ram 1.6 (defmethod class-prototype ((class structure-class))
173     (with-slots (prototype wrapper defstruct-constructor) class
174     (or prototype
175     (setq prototype
176 pw 1.23 (if defstruct-constructor
177 ram 1.6 (allocate-instance class)
178     (allocate-standard-instance wrapper))))))
179 ram 1.4
180 ram 1.6 (defmethod class-direct-default-initargs ((class slot-class))
181     (plist-value class 'direct-default-initargs))
182    
183     (defmethod class-default-initargs ((class slot-class))
184     (plist-value class 'default-initargs))
185    
186 ram 1.4 (defmethod class-constructors ((class slot-class))
187 wlott 1.1 (plist-value class 'constructors))
188    
189     (defmethod class-slot-cells ((class std-class))
190     (plist-value class 'class-slot-cells))
191    
192    
193     ;;;
194     ;;; Class accessors that are even a little bit more complicated than those
195     ;;; above. These have a protocol for updating them, we must implement that
196     ;;; protocol.
197     ;;;
198    
199     ;;;
200     ;;; Maintaining the direct subclasses backpointers. The update methods are
201     ;;; here, the values are read by an automatically generated reader method.
202     ;;;
203     (defmethod add-direct-subclass ((class class) (subclass class))
204 gerd 1.44 (check-seals class 'add-direct-subclass)
205 wlott 1.1 (with-slots (direct-subclasses) class
206     (pushnew subclass direct-subclasses)
207     subclass))
208    
209     (defmethod remove-direct-subclass ((class class) (subclass class))
210 gerd 1.44 (check-seals class 'remove-direct-subclass)
211 wlott 1.1 (with-slots (direct-subclasses) class
212     (setq direct-subclasses (remove subclass direct-subclasses))
213     subclass))
214    
215     ;;;
216     ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
217     ;;;
218     ;;; There are four generic functions involved, each has one method for the
219     ;;; class case and another method for the damned EQL specializers. All of
220     ;;; these are specified methods and appear in their specified place in the
221     ;;; class graph.
222     ;;;
223 ram 1.4 ;;; ADD-DIRECT-METHOD
224     ;;; REMOVE-DIRECT-METHOD
225     ;;; SPECIALIZER-DIRECT-METHODS
226     ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
227 wlott 1.1 ;;;
228     ;;; In each case, we maintain one value which is a cons. The car is the list
229     ;;; methods. The cdr is a list of the generic functions. The cdr is always
230     ;;; computed lazily.
231     ;;;
232    
233 ram 1.4 (defmethod add-direct-method ((specializer class) (method method))
234 wlott 1.1 (with-slots (direct-methods) specializer
235     (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
236     (cdr direct-methods) ()))
237     method)
238    
239 ram 1.4 (defmethod remove-direct-method ((specializer class) (method method))
240 wlott 1.1 (with-slots (direct-methods) specializer
241     (setf (car direct-methods) (remove method (car direct-methods))
242     (cdr direct-methods) ()))
243 gerd 1.44 (remove-inline-access-method specializer method)
244 wlott 1.1 method)
245    
246 ram 1.4 (defmethod specializer-direct-methods ((specializer class))
247 wlott 1.1 (with-slots (direct-methods) specializer
248     (car direct-methods)))
249    
250 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer class))
251 wlott 1.1 (with-slots (direct-methods) specializer
252     (or (cdr direct-methods)
253     (setf (cdr direct-methods)
254 pmai 1.32 (loop for method in (car direct-methods)
255     for generic-function = (method-generic-function method)
256     unless (member generic-function collected :test #'eq)
257     collect generic-function into collected
258     finally (return collected))))))
259 wlott 1.1
260    
261     ;;;
262     ;;; This hash table is used to store the direct methods and direct generic
263     ;;; functions of EQL specializers. Each value in the table is the cons.
264     ;;;
265 gerd 1.44 (defvar *eql-specializer-methods* (make-hash-table :test 'eql))
266     (defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
267 wlott 1.1
268 ram 1.4 (defmethod specializer-method-table ((specializer eql-specializer))
269     *eql-specializer-methods*)
270    
271     (defmethod specializer-method-table ((specializer class-eq-specializer))
272     *class-eq-specializer-methods*)
273    
274     (defmethod add-direct-method ((specializer specializer-with-object) (method method))
275 ram 1.2 (let* ((object (specializer-object specializer))
276 ram 1.4 (table (specializer-method-table specializer))
277     (entry (gethash object table)))
278 wlott 1.1 (unless entry
279     (setq entry
280 ram 1.4 (setf (gethash object table)
281 wlott 1.1 (cons nil nil))))
282     (setf (car entry) (adjoin method (car entry))
283     (cdr entry) ())
284     method))
285    
286 ram 1.4 (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
287 ram 1.2 (let* ((object (specializer-object specializer))
288 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
289 wlott 1.1 (when entry
290     (setf (car entry) (remove method (car entry))
291     (cdr entry) ()))
292     method))
293    
294 ram 1.4 (defmethod specializer-direct-methods ((specializer specializer-with-object))
295     (car (gethash (specializer-object specializer)
296     (specializer-method-table specializer))))
297 wlott 1.1
298 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
299 ram 1.2 (let* ((object (specializer-object specializer))
300 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
301 wlott 1.1 (when entry
302     (or (cdr entry)
303     (setf (cdr entry)
304 pmai 1.32 (loop for method in (car entry)
305     for generic-function = (method-generic-function method)
306     unless (member generic-function collected :test #'eq)
307     collect generic-function into collected
308     finally (return collected)))))))
309 wlott 1.1
310 ram 1.4 (defun map-specializers (function)
311 pmai 1.32 (map-all-classes (lambda (class)
312     (funcall function (class-eq-specializer class))
313     (funcall function class)))
314     (maphash (lambda (object methods)
315     (declare (ignore methods))
316     (intern-eql-specializer object))
317 ram 1.4 *eql-specializer-methods*)
318 pmai 1.32 (maphash (lambda (object specl)
319     (declare (ignore object))
320     (funcall function specl))
321 ram 1.4 *eql-specializer-table*)
322     nil)
323    
324 gerd 1.44 (defun map-all-classes (function &optional (root t))
325     (let ((braid-p (memq *boot-state* '(braid complete)))
326     (root (if (symbolp root) (find-class root) root)))
327     (labels ((map-class (class)
328     (mapc #'map-class
329     (if braid-p
330     (class-direct-subclasses class)
331     (early-class-direct-subclasses class)))
332     (funcall function class)))
333     (map-class root))))
334    
335 ram 1.4 (defun map-all-generic-functions (function)
336     (let ((all-generic-functions (make-hash-table :test 'eq)))
337 pmai 1.32 (map-specializers (lambda (specl)
338     (dolist (gf (specializer-direct-generic-functions specl))
339     (unless (gethash gf all-generic-functions)
340     (setf (gethash gf all-generic-functions) t)
341     (funcall function gf))))))
342 ram 1.4 nil)
343    
344     (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
345     (declare (ignore slot-names))
346     (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
347    
348     (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
349     (declare (ignore slot-names))
350     (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
351    
352 wlott 1.1
353    
354 dtc 1.24 (defun real-load-defclass (name metaclass-name supers slots other)
355 gerd 1.44 (apply #'ensure-class name :metaclass metaclass-name
356     :direct-superclasses supers
357     :direct-slots slots
358     :definition-source `((defclass ,name) ,*load-pathname*)
359     other))
360 wlott 1.1
361 phg 1.7 (setf (gdefinition 'load-defclass) #'real-load-defclass)
362 ram 1.6
363     (defun ensure-class (name &rest all)
364 gerd 1.47 (apply #'ensure-class-using-class (find-class name nil) name all))
365 ram 1.6
366 gerd 1.47 (defmethod ensure-class-using-class ((class null) name &rest args &key)
367 ram 1.6 (multiple-value-bind (meta initargs)
368     (ensure-class-values class args)
369 gerd 1.44 (inform-type-system-about-class (class-prototype meta) name)
370 ram 1.6 (setf class (apply #'make-instance meta :name name initargs)
371 phg 1.7 (find-class name) class)
372 gerd 1.44 (inform-type-system-about-class class name)
373 ram 1.6 class))
374    
375 gerd 1.47 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
376 ram 1.6 (multiple-value-bind (meta initargs)
377     (ensure-class-values class args)
378 gerd 1.44 (unless (eq (class-of class) meta)
379 gerd 1.49 (apply #'change-class class meta initargs))
380 ram 1.6 (apply #'reinitialize-instance class initargs)
381 phg 1.7 (setf (find-class name) class)
382 gerd 1.44 (inform-type-system-about-class class name)
383 ram 1.6 class))
384    
385 phg 1.7 (defmethod class-predicate-name ((class t))
386     'function-returning-nil)
387    
388 wlott 1.1 (defun ensure-class-values (class args)
389     (let* ((initargs (copy-list args))
390     (unsupplied (list 1))
391     (supplied-meta (getf initargs :metaclass unsupplied))
392     (supplied-supers (getf initargs :direct-superclasses unsupplied))
393 gerd 1.44 (meta (cond ((neq supplied-meta unsupplied)
394     (find-class supplied-meta))
395     ((or (null class)
396     (forward-referenced-class-p class))
397     *the-class-standard-class*)
398     (t
399     (class-of class)))))
400 gerd 1.50 (flet ((fix-super (super)
401     (cond ((classp super)
402     super)
403     ((legal-class-name-p super)
404     (or (find-class super nil)
405     (make-instance 'forward-referenced-class
406     :name super)))
407     (t
408 pmai 1.33 (simple-program-error
409 gerd 1.50 "~@<~S is not a class or a legal class name.~@:>"
410     super)))))
411 pmai 1.31 ;;
412     ;; CLHS: signal PROGRAM-ERROR, if
413     ;; (a) there are any duplicate slot names
414     ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
415     ;; :DOCUMENTATION appears more than one in a single slot description.
416     (loop for (slot . more) on (getf initargs :direct-slots)
417     for slot-name = (getf slot :name)
418     if (some (lambda (s) (eq slot-name (getf s :name))) more) do
419 pmai 1.33 (simple-program-error
420 gerd 1.44 "~@<More than one direct slot with name ~S.~@:>"
421 pmai 1.33 slot-name)
422 pmai 1.31 else do
423     (loop for (option value . more) on slot by #'cddr
424 gerd 1.44 if (and (member option '(:allocation :type :initform
425     :documentation))
426     (not (eq unsupplied
427     (getf more option unsupplied)))) do
428     (simple-program-error
429     "~@<Duplicate slot option ~S for slot ~S.~@:>"
430     option slot-name)
431     else if (and (eq option :readers)
432     (notevery #'symbolp value)) do
433     (simple-program-error
434     "~@<Slot ~S: slot reader names must be symbols.~@:>"
435     slot-name)
436     else if (and (eq option :initargs)
437     (notevery #'symbolp value)) do
438 pmai 1.33 (simple-program-error
439 gerd 1.44 "~@<Slot ~S: initarg names must be symbols.~@:>"
440     slot-name)))
441 pmai 1.31 ;;
442     ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
443     ;; appears more than once in :DEFAULT-INITARGS class option.
444     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
445     for name = (car initarg)
446     when (some (lambda (a) (eq (car a) name)) more) do
447 pmai 1.33 (simple-program-error
448 gerd 1.44 "~@<Duplicate initialization argument ~
449     name ~S in ~s of class ~A.~@:>"
450     name :default-initargs class))
451     ;;
452     (loop for (arg value) on initargs by #'cddr
453     count (eq arg :metaclass) into metaclass
454     count (eq arg :direct-default-initargs) into default-initargs
455     when (or (> metaclass 1) (> default-initargs 1)) do
456     (simple-program-error
457     "~@<Class ~S: More than one ~S specified~@:>"
458     class (if (eq arg :direct-default-initargs)
459     :default-initargs arg)))
460     (remf initargs :metaclass)
461     (remf initargs :direct-superclasses)
462 pmai 1.31 ;;
463 wlott 1.1 (values meta
464 gerd 1.44 (nconc (when (neq supplied-supers unsupplied)
465     (list :direct-superclasses
466     (mapcar #'fix-super supplied-supers)))
467     initargs)))))
468 wlott 1.1
469    
470     ;;;
471     ;;;
472     ;;;
473     (defmethod shared-initialize :after
474     ((class std-class)
475     slot-names
476 ram 1.2 &key (direct-superclasses nil direct-superclasses-p)
477     (direct-slots nil direct-slots-p)
478 ram 1.4 (direct-default-initargs nil direct-default-initargs-p)
479     (predicate-name nil predicate-name-p))
480 wlott 1.1 (declare (ignore slot-names))
481 pmai 1.28 (cond ((or direct-superclasses-p
482     (null (slot-value class 'direct-superclasses)))
483 dtc 1.17 (setq direct-superclasses
484     (or direct-superclasses
485     (list (if (funcallable-standard-class-p class)
486     *the-class-funcallable-standard-object*
487     *the-class-standard-object*))))
488     (dolist (superclass direct-superclasses)
489     (unless (validate-superclass class superclass)
490 gerd 1.44 (error "~@<The class ~S was specified as a ~
491     super-class of the class ~S, ~
492     but the meta-classes ~S and ~S are incompatible. ~
493     Define a method for ~S to avoid this error.~@:>"
494 dtc 1.17 superclass class (class-of superclass) (class-of class)
495     'validate-superclass)))
496     (setf (slot-value class 'direct-superclasses) direct-superclasses))
497     (t
498     (setq direct-superclasses (slot-value class 'direct-superclasses))))
499 ram 1.2 (setq direct-slots
500     (if direct-slots-p
501     (setf (slot-value class 'direct-slots)
502 gerd 1.50 (mapcar (lambda (pl) (make-direct-slotd class pl))
503     direct-slots))
504 ram 1.2 (slot-value class 'direct-slots)))
505     (if direct-default-initargs-p
506 gerd 1.50 (setf (plist-value class 'direct-default-initargs)
507     direct-default-initargs)
508     (setq direct-default-initargs
509     (plist-value class 'direct-default-initargs)))
510 gerd 1.56 ;;
511     ;; Initialize shared slots. A class may inherit initforms for
512     ;; shared slots from superclasses. Such initializations are
513     ;; done in UPDATE-CLASS-SLOT-VALUES.
514     (ext:collect ((cells))
515     (dolist (dslotd direct-slots)
516     (when (eq (slot-definition-allocation dslotd) :class)
517     (let ((initfn (slot-definition-initfunction dslotd)))
518     (cells (cons (slot-definition-name dslotd)
519     (if initfn
520     (funcall initfn)
521     +slot-unbound+))))))
522     (setf (plist-value class 'class-slot-cells) (cells)))
523     ;;
524 ram 1.6 (setq predicate-name (if predicate-name-p
525     (setf (slot-value class 'predicate-name)
526     (car predicate-name))
527     (or (slot-value class 'predicate-name)
528     (setf (slot-value class 'predicate-name)
529     (make-class-predicate-name (class-name class))))))
530 wlott 1.1 (add-direct-subclasses class direct-superclasses)
531 gerd 1.47 (make-class-predicate class predicate-name)
532 ram 1.6 (update-class class nil)
533 gerd 1.50 (add-slot-accessors class direct-slots)
534     (make-preliminary-layout class))
535    
536     (defmethod shared-initialize :after ((class forward-referenced-class)
537     slot-names &key &allow-other-keys)
538     (declare (ignore slot-names))
539     (make-preliminary-layout class))
540    
541     ;;;
542     ;;; Give CLASS a preliminary layout, if it doesn't have a layout
543     ;;; already. This is done to make CLASS known to the type system
544     ;;; before the class is finalized, and is a consequence of the class
545     ;;; schizophrenia we are suffering from.
546     ;;;
547     (defvar *allow-forward-referenced-classes-in-cpl-p* nil)
548    
549     (defun make-preliminary-layout (class)
550     (flet ((compute-preliminary-cpl (root)
551     (let ((*allow-forward-referenced-classes-in-cpl-p* t))
552     (compute-class-precedence-list root))))
553     (unless (class-finalized-p class)
554     (let ((name (class-name class)))
555     (setf (find-class name) class)
556     (inform-type-system-about-class class name)
557     (let ((layout (make-wrapper 0 class))
558     (kernel-class (kernel::find-class name)))
559     (setf (kernel:layout-class layout) kernel-class)
560     (setf (kernel:%class-pcl-class kernel-class) class)
561     (setf (slot-value class 'wrapper) layout)
562     (let ((cpl (compute-preliminary-cpl class)))
563     (setf (kernel:layout-inherits layout)
564     (kernel:order-layout-inherits
565     (map 'simple-vector #'class-wrapper
566     (reverse (rest cpl))))))
567     (kernel:register-layout layout :invalidate t)
568 gerd 1.53 (setf (kernel:%class-layout kernel-class) layout)
569     (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
570 wlott 1.1
571 ram 1.6 (defmethod shared-initialize :before ((class class) slot-names &key name)
572     (declare (ignore slot-names name))
573 ram 1.4 (setf (slot-value class 'type) `(class ,class))
574     (setf (slot-value class 'class-eq-specializer)
575     (make-instance 'class-eq-specializer :class class)))
576    
577 pw 1.22 (defmethod reinitialize-instance :before ((class slot-class)
578     &key direct-superclasses)
579     (remove-direct-subclasses class direct-superclasses)
580 wlott 1.1 (remove-slot-accessors class (class-direct-slots class)))
581    
582 ram 1.6 (defmethod reinitialize-instance :after ((class slot-class)
583 wlott 1.1 &rest initargs
584     &key)
585     (map-dependents class
586 pmai 1.32 (lambda (dependent)
587     (apply #'update-dependent class dependent initargs))))
588 ram 1.4
589 ram 1.6 (defmethod shared-initialize :after
590     ((class structure-class)
591     slot-names
592     &key (direct-superclasses nil direct-superclasses-p)
593     (direct-slots nil direct-slots-p)
594     direct-default-initargs
595     (predicate-name nil predicate-name-p))
596     (declare (ignore slot-names direct-default-initargs))
597     (if direct-superclasses-p
598     (setf (slot-value class 'direct-superclasses)
599     (or direct-superclasses
600     (setq direct-superclasses
601     (and (not (eq (class-name class) 'structure-object))
602     (list *the-class-structure-object*)))))
603     (setq direct-superclasses (slot-value class 'direct-superclasses)))
604     (let* ((name (class-name class))
605     (from-defclass-p (slot-value class 'from-defclass-p))
606     (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
607     (if direct-slots-p
608     (setf (slot-value class 'direct-slots)
609     (setq direct-slots
610 pmai 1.32 (mapcar (lambda (pl)
611     (when defstruct-p
612     (let* ((slot-name (getf pl :name))
613 gerd 1.44 (accessor
614     (symbolicate
615     *package*
616     (if (symbol-package name)
617     (package-name (symbol-package name))
618     "")
619     "::" name " structure class " slot-name)))
620 pmai 1.32 (setq pl (list* :defstruct-accessor-symbol accessor
621     pl))))
622     (make-direct-slotd class pl))
623 ram 1.6 direct-slots)))
624     (setq direct-slots (slot-value class 'direct-slots)))
625     (when defstruct-p
626     (let* ((include (car (slot-value class 'direct-superclasses)))
627 gerd 1.44 (conc-name (symbolicate *package*
628     (if (symbol-package name)
629     (package-name (symbol-package name))
630     "")
631     "::" name " structure class "))
632     ;;
633     ;; It's not possible to use a generalized name for the
634     ;; constructor function. It shouldn't matter though, I think,
635     ;; like for the slot names above, because this stuff is not
636     ;; supposed to be used by users directly.
637     (constructor
638     (symbolicate *package* conc-name " constructor"))
639 ram 1.6 (defstruct `(defstruct (,name
640     ,@(when include
641     `((:include ,(class-name include))))
642     (:predicate nil)
643     (:conc-name ,conc-name)
644     (:constructor ,constructor ()))
645 gerd 1.44 ;;
646     ;; Use a temporary unbound marker that lets
647     ;; SHARED-INITIALIZE recognize if a before-method
648     ;; has written to a slot.
649 pmai 1.32 ,@(mapcar (lambda (slot)
650     `(,(slot-definition-name slot)
651 gerd 1.44 '.unbound.))
652 ram 1.6 direct-slots)))
653 pmai 1.32 (reader-names (mapcar (lambda (slotd)
654 gerd 1.44 (list 'slot-accessor name
655     (slot-definition-name slotd)
656     'reader))
657 ram 1.6 direct-slots))
658 pmai 1.32 (writer-names (mapcar (lambda (slotd)
659 gerd 1.44 (list 'slot-accessor name
660     (slot-definition-name slotd)
661     'writer))
662 ram 1.6 direct-slots))
663     (readers-init
664 pmai 1.32 (mapcar (lambda (slotd reader-name)
665     (let ((accessor
666     (slot-definition-defstruct-accessor-symbol slotd)))
667     `(defun ,reader-name (obj)
668     (declare (type ,name obj))
669     (,accessor obj))))
670 ram 1.6 direct-slots reader-names))
671     (writers-init
672 pmai 1.32 (mapcar (lambda (slotd writer-name)
673     (let ((accessor
674     (slot-definition-defstruct-accessor-symbol slotd)))
675     `(defun ,writer-name (nv obj)
676     (declare (type ,name obj))
677     (setf (,accessor obj) nv))))
678 ram 1.6 direct-slots writer-names))
679     (defstruct-form
680     `(progn
681     ,defstruct
682 pw 1.27 ,@readers-init ,@writers-init)))
683 ram 1.6 (unless (structure-type-p name) (eval defstruct-form))
684 pmai 1.32 (mapc (lambda (dslotd reader-name writer-name)
685 gerd 1.48 (let* ((reader (when (fboundp reader-name)
686     (gdefinition reader-name)))
687 pmai 1.32 (writer (when (fboundp writer-name)
688     (gdefinition writer-name))))
689     (setf (slot-value dslotd 'internal-reader-function) reader)
690     (setf (slot-value dslotd 'internal-writer-function) writer)))
691 ram 1.6 direct-slots reader-names writer-names)
692     (setf (slot-value class 'defstruct-form) defstruct-form)
693     (setf (slot-value class 'defstruct-constructor) constructor))))
694     (add-direct-subclasses class direct-superclasses)
695     (setf (slot-value class 'class-precedence-list)
696     (compute-class-precedence-list class))
697     (setf (slot-value class 'slots) (compute-slots class))
698 gerd 1.44 (let ((lclass (kernel::find-class (class-name class))))
699     (setf (kernel:%class-pcl-class lclass) class)
700     (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
701 gerd 1.50 (setf (slot-value class 'finalized-p) t)
702 ram 1.6 (update-pv-table-cache-info class)
703     (setq predicate-name (if predicate-name-p
704     (setf (slot-value class 'predicate-name)
705     (car predicate-name))
706     (or (slot-value class 'predicate-name)
707     (setf (slot-value class 'predicate-name)
708     (make-class-predicate-name (class-name class))))))
709     (make-class-predicate class predicate-name)
710     (add-slot-accessors class direct-slots))
711 ram 1.4
712 ram 1.6 (defmethod direct-slot-definition-class ((class structure-class) initargs)
713     (declare (ignore initargs))
714     (find-class 'structure-direct-slot-definition))
715    
716     (defmethod finalize-inheritance ((class structure-class))
717     nil) ; always finalized
718 wlott 1.1
719     (defun add-slot-accessors (class dslotds)
720     (fix-slot-accessors class dslotds 'add))
721    
722     (defun remove-slot-accessors (class dslotds)
723     (fix-slot-accessors class dslotds 'remove))
724    
725 gerd 1.44 (defun fix-slot-accessors (class dslotds add/remove)
726 ram 1.6 (flet ((fix (gfspec name r/w)
727 wlott 1.1 (let ((gf (ensure-generic-function gfspec)))
728     (case r/w
729     (r (if (eq add/remove 'add)
730 ram 1.6 (add-reader-method class gf name)
731 wlott 1.1 (remove-reader-method class gf)))
732     (w (if (eq add/remove 'add)
733 ram 1.6 (add-writer-method class gf name)
734 wlott 1.1 (remove-writer-method class gf)))))))
735     (dolist (dslotd dslotds)
736 ram 1.6 (let ((slot-name (slot-definition-name dslotd)))
737 gerd 1.44 (dolist (r (slot-definition-readers dslotd))
738     (fix r slot-name 'r))
739     (dolist (w (slot-definition-writers dslotd))
740     (fix w slot-name 'w))))))
741 wlott 1.1
742    
743     (defun add-direct-subclasses (class new)
744     (dolist (n new)
745     (unless (memq class (class-direct-subclasses class))
746     (add-direct-subclass n class))))
747    
748     (defun remove-direct-subclasses (class new)
749     (let ((old (class-direct-superclasses class)))
750     (dolist (o (set-difference old new))
751     (remove-direct-subclass o class))))
752    
753    
754     ;;;
755     ;;;
756     ;;;
757     (defmethod finalize-inheritance ((class std-class))
758     (update-class class t))
759 pmai 1.41
760     (defmethod finalize-inheritance ((class forward-referenced-class))
761     (simple-program-error
762 gerd 1.44 "~@<Forward-referenced classes cannot be finalized: ~A.~@:>"
763 pmai 1.41 class))
764 wlott 1.1
765    
766     ;;;
767 ram 1.4 ;;; Called by :after shared-initialize whenever a class is initialized or
768     ;;; reinitialized. The class may or may not be finalized.
769 wlott 1.1 ;;;
770 gerd 1.44 (defun update-class (class finalizep)
771 pmai 1.40 ;;
772 gerd 1.44 ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
773     ;; makes the class finalized. When UPDATE-CLASS isn't called from
774     ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
775     ;; FINALIZE-INHERITANCE as per AMOP. Note that we can't simply
776     ;; delay the finalization when CLASS has no forward referenced
777     ;; superclasses because that causes bootstrap problems.
778     (when (and (not (or finalizep (class-finalized-p class)))
779 pmai 1.40 (not (class-has-a-forward-referenced-superclass-p class)))
780     (finalize-inheritance class)
781     (return-from update-class))
782 gerd 1.44 ;;
783     (when (or finalizep
784     (class-finalized-p class)
785 ram 1.6 (not (class-has-a-forward-referenced-superclass-p class)))
786 gerd 1.47 (setf (find-class (class-name class)) class)
787 ram 1.4 (update-cpl class (compute-class-precedence-list class))
788 ram 1.6 (update-slots class (compute-slots class))
789 ram 1.4 (update-gfs-of-class class)
790     (update-inits class (compute-default-initargs class))
791 gerd 1.56 (update-shared-slot-values class)
792 gerd 1.44 (update-ctors 'finalize-inheritance :class class))
793     ;;
794 wlott 1.1 (unless finalizep
795 gerd 1.44 (dolist (sub (class-direct-subclasses class))
796     (update-class sub nil))))
797 gerd 1.56
798     ;;;
799     ;;; Set values of shared slots from initforms inherited from
800     ;;; superclasses, which can't be done before the cpl is known.
801     ;;;
802     (defun update-shared-slot-values (class)
803     (dolist (slot (class-slots class))
804     (when (eq (slot-definition-allocation slot) :class)
805     (let ((cell (assq (slot-definition-name slot) (class-slot-cells class))))
806     (when cell
807     (let ((initfn (slot-definition-initfunction slot)))
808     (when initfn
809     (setf (cdr cell) (funcall initfn)))))))))
810 wlott 1.1
811     (defun update-cpl (class cpl)
812 dtc 1.13 (if (class-finalized-p class)
813 gerd 1.55 (unless (and (equal (class-precedence-list class) cpl)
814     (loop for c in cpl never
815     (loop for s in (class-direct-slots c) thereis
816     (eq (slot-definition-allocation s)
817     :class))))
818 dtc 1.13 ;; Need to have the cpl setup before update-lisp-class-layout
819     ;; is called on CMUCL.
820     (setf (slot-value class 'class-precedence-list) cpl)
821     (force-cache-flushes class))
822     (setf (slot-value class 'class-precedence-list) cpl))
823 ram 1.4 (update-class-can-precede-p cpl))
824 gerd 1.51
825 ram 1.4 (defun update-class-can-precede-p (cpl)
826 gerd 1.51 (loop for (class . rest) on cpl do
827     (with-slots (can-precede-list) class
828     (setq can-precede-list
829     (union rest can-precede-list :test #'eq)))))
830 ram 1.4
831     (defun class-can-precede-p (class1 class2)
832 ram 1.6 (member class2 (class-can-precede-list class1)))
833 ram 1.4
834 ram 1.6 (defun update-slots (class eslotds)
835 gerd 1.51 (ext:collect ((instance-slots) (class-slots))
836 ram 1.4 (dolist (eslotd eslotds)
837 pmai 1.38 (ecase (slot-definition-allocation eslotd)
838 gerd 1.51 (:instance (instance-slots eslotd))
839     (:class (class-slots eslotd))))
840 ram 1.6 ;;
841     ;; If there is a change in the shape of the instances then the
842     ;; old class is now obsolete.
843     (let* ((nlayout (mapcar #'slot-definition-name
844 gerd 1.51 (sort (instance-slots) #'<
845 pmai 1.42 :key #'slot-definition-location)))
846 ram 1.6 (nslots (length nlayout))
847 gerd 1.51 (nwrapper-class-slots (compute-class-slots (class-slots)))
848     (owrapper (when (class-finalized-p class)
849     (class-wrapper class)))
850     (olayout (when owrapper
851     (wrapper-instance-slots-layout owrapper)))
852 ram 1.6 (nwrapper
853     (cond ((null owrapper)
854     (make-wrapper nslots class))
855 pmai 1.42 ;;
856     ;; We cannot reuse the old wrapper easily when it
857     ;; has class slot cells, even if these cells are
858 gerd 1.44 ;; EQUAL to the ones used in the new wrapper. The
859 pmai 1.42 ;; class slot cells of OWRAPPER may be referenced
860     ;; from caches, and if we don't change the wrapper,
861     ;; the caches won't notice that something has
862     ;; changed. We could do something here manually,
863     ;; but I don't think it's worth it.
864 ram 1.6 ((and (equal nlayout olayout)
865 pmai 1.42 (null (wrapper-class-slots owrapper)))
866 ram 1.6 owrapper)
867     (t
868     ;;
869     ;; This will initialize the new wrapper to have the same
870     ;; state as the old wrapper. We will then have to change
871     ;; that. This may seem like wasted work (it is), but the
872     ;; spec requires that we call make-instances-obsolete.
873     (make-instances-obsolete class)
874     (class-wrapper class)))))
875 pw 1.9
876 gerd 1.51 (with-slots (wrapper slots finalized-p) class
877 pw 1.9 (update-lisp-class-layout class nwrapper)
878 ram 1.6 (setf slots eslotds
879     (wrapper-instance-slots-layout nwrapper) nlayout
880     (wrapper-class-slots nwrapper) nwrapper-class-slots
881     (wrapper-no-of-instance-slots nwrapper) nslots
882 gerd 1.51 wrapper nwrapper
883     finalized-p t))
884 pw 1.9
885 ram 1.6 (unless (eq owrapper nwrapper)
886 gerd 1.44 (update-inline-access class)
887 gerd 1.46 (update-pv-table-cache-info class)
888     (maybe-update-standard-class-locations class)))))
889 wlott 1.1
890 ram 1.6 (defun compute-class-slots (eslotds)
891 pmai 1.32 (loop for eslotd in eslotds
892     for name = (slot-definition-name eslotd)
893 pmai 1.38 and class = (slot-definition-class eslotd)
894     collect (assoc name (class-slot-cells class))))
895 wlott 1.1
896 ram 1.4 (defun update-gfs-of-class (class)
897 ram 1.6 (when (and (class-finalized-p class)
898     (let ((cpl (class-precedence-list class)))
899     (or (member *the-class-slot-class* cpl)
900     (member *the-class-standard-effective-slot-definition* cpl))))
901 ram 1.4 (let ((gf-table (make-hash-table :test 'eq)))
902     (labels ((collect-gfs (class)
903     (dolist (gf (specializer-direct-generic-functions class))
904     (setf (gethash gf gf-table) t))
905     (mapc #'collect-gfs (class-direct-superclasses class))))
906     (collect-gfs class)
907 pmai 1.32 (maphash (lambda (gf ignore)
908     (declare (ignore ignore))
909     (update-gf-dfun class gf))
910 ram 1.4 gf-table)))))
911 wlott 1.1
912     (defun update-inits (class inits)
913 ram 1.6 (setf (plist-value class 'default-initargs) inits))
914 wlott 1.1
915    
916     ;;;
917     ;;;
918     ;;;
919 ram 1.4 (defmethod compute-default-initargs ((class slot-class))
920 gerd 1.54 (let ((initargs (loop for c in (class-precedence-list class)
921     append (class-direct-default-initargs c))))
922     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
923 wlott 1.1
924     ;;;
925     ;;; Protocols for constructing direct and effective slot definitions.
926     ;;;
927     ;;;
928     ;;;
929     ;;;
930     (defmethod direct-slot-definition-class ((class std-class) initargs)
931     (declare (ignore initargs))
932     (find-class 'standard-direct-slot-definition))
933    
934 ram 1.6 (defun make-direct-slotd (class initargs)
935     (let ((initargs (list* :class class initargs)))
936 gerd 1.44 (apply #'make-instance (direct-slot-definition-class class initargs)
937     initargs)))
938 ram 1.6
939 wlott 1.1 ;;;
940 gerd 1.44 ;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
941     ;;; for each different slot name we find in our superclasses. Each
942     ;;; call receives the class and a list of the dslotds with that name.
943     ;;; The list is in most-specific-first order.
944     ;;;
945     (defmethod compute-slots ((class std-class))
946     (loop with names/slots = ()
947     for c in (class-precedence-list class) do
948     (loop for slot in (class-direct-slots c)
949     as name = (slot-definition-name slot)
950     as entry = (assq name names/slots) do
951     (if entry
952     (push slot (cdr entry))
953     (push (list name slot) names/slots)))
954     finally
955     (return
956     (loop for (name . slots) in names/slots collect
957     (compute-effective-slot-definition
958 gerd 1.52 class name (nreverse slots))))))
959 gerd 1.44
960 wlott 1.1 ;;;
961 gerd 1.44 ;;; These are the specified AMOP methods.
962 wlott 1.1 ;;;
963    
964 pmai 1.39 (defmethod compute-slots ((class standard-class))
965     (call-next-method))
966 gerd 1.44
967 pmai 1.39 (defmethod compute-slots :around ((class standard-class))
968 gerd 1.44 (loop with slotds = (call-next-method) and location = -1
969     for slot in slotds do
970     (setf (slot-definition-location slot)
971     (ecase (slot-definition-allocation slot)
972     (:instance
973     (incf location))
974     (:class
975     (let* ((name (slot-definition-name slot))
976     (from-class (slot-definition-allocation-class slot))
977     (cell (assq name (class-slot-cells from-class))))
978     (assert (consp cell))
979     cell))))
980     (initialize-internal-slot-functions slot)
981     finally
982     (return slotds)))
983 pmai 1.39
984     (defmethod compute-slots ((class funcallable-standard-class))
985     (call-next-method))
986    
987     (defmethod compute-slots :around ((class funcallable-standard-class))
988 gerd 1.44 (labels (;;
989     ;; Return a list of the names of instance slots in SLOTDS.
990     (instance-slot-names (slotds)
991     (loop for e in slotds
992     when (eq (slot-definition-allocation e) :instance)
993     collect (slot-definition-name e)))
994     ;;
995 pmai 1.39 ;; This sorts slots so that slots of classes later in the CPL
996 gerd 1.44 ;; come before slots of other classes. This is crucial for
997     ;; funcallable instances because it ensures that the slots of
998     ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
999     ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
1000     ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
1001     ;; a funcallable instance.
1002 pmai 1.39 (compute-layout (eslotds)
1003 gerd 1.44 (loop with first = ()
1004     with names = (instance-slot-names eslotds)
1005     for class in (reverse (class-precedence-list class)) do
1006     (loop for ss in (class-slots class)
1007     as name = (slot-definition-name ss)
1008     when (member name names) do
1009     (push name first)
1010     (setq names (delete name names)))
1011     finally (return (nreverse (nconc names first))))))
1012     ;;
1013 pmai 1.39 (let ((all-slotds (call-next-method))
1014     (instance-slots ())
1015     (class-slots ()))
1016 gerd 1.44 (loop for slotd in all-slotds do
1017     (ecase (slot-definition-allocation slotd)
1018     (:instance (push slotd instance-slots))
1019     (:class (push slotd class-slots))))
1020     (loop with layout = (compute-layout instance-slots)
1021     for slotd in instance-slots do
1022     (setf (slot-definition-location slotd)
1023     (position (slot-definition-name slotd) layout))
1024     (initialize-internal-slot-functions slotd))
1025     (loop for slotd in class-slots
1026     as name = (slot-definition-name slotd)
1027     as from-class = (slot-definition-allocation-class slotd) do
1028     (setf (slot-definition-location slotd)
1029     (assoc name (class-slot-cells from-class)))
1030     (assert (consp (slot-definition-location slotd)))
1031     (initialize-internal-slot-functions slotd))
1032 pmai 1.39 all-slotds)))
1033 ram 1.4
1034 ram 1.6 (defmethod compute-slots ((class structure-class))
1035 pmai 1.32 (mapcan (lambda (superclass)
1036     (mapcar (lambda (dslotd)
1037 gerd 1.52 (compute-effective-slot-definition
1038     class (slot-definition-name dslotd) (list dslotd)))
1039 pmai 1.32 (class-direct-slots superclass)))
1040 ram 1.6 (reverse (slot-value class 'class-precedence-list))))
1041 ram 1.4
1042 ram 1.6 (defmethod compute-slots :around ((class structure-class))
1043     (let ((eslotds (call-next-method)))
1044     (mapc #'initialize-internal-slot-functions eslotds)
1045     eslotds))
1046    
1047 gerd 1.52 (defmethod compute-effective-slot-definition
1048     ((class slot-class) slot-name dslotds)
1049     (declare (ignore slot-name))
1050 wlott 1.1 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
1051 ram 1.6 (class (effective-slot-definition-class class initargs)))
1052     (apply #'make-instance class initargs)))
1053 wlott 1.1
1054     (defmethod effective-slot-definition-class ((class std-class) initargs)
1055     (declare (ignore initargs))
1056 ram 1.6 (find-class 'standard-effective-slot-definition))
1057 wlott 1.1
1058 ram 1.6 (defmethod effective-slot-definition-class ((class structure-class) initargs)
1059     (declare (ignore initargs))
1060     (find-class 'structure-effective-slot-definition))
1061    
1062 ram 1.4 (defmethod compute-effective-slot-definition-initargs
1063     ((class slot-class) direct-slotds)
1064 wlott 1.1 (let* ((name nil)
1065     (initfunction nil)
1066     (initform nil)
1067     (initargs nil)
1068     (allocation nil)
1069 pmai 1.39 (allocation-class nil)
1070 wlott 1.1 (type t)
1071     (namep nil)
1072     (initp nil)
1073 ram 1.6 (allocp nil))
1074 wlott 1.1
1075     (dolist (slotd direct-slotds)
1076     (when slotd
1077     (unless namep
1078 ram 1.4 (setq name (slot-definition-name slotd)
1079 wlott 1.1 namep t))
1080     (unless initp
1081 ram 1.4 (when (slot-definition-initfunction slotd)
1082 ram 1.6 (setq initform (slot-definition-initform slotd)
1083     initfunction (slot-definition-initfunction slotd)
1084 wlott 1.1 initp t)))
1085     (unless allocp
1086 ram 1.4 (setq allocation (slot-definition-allocation slotd)
1087 pmai 1.39 allocation-class (slot-definition-class slotd)
1088 wlott 1.1 allocp t))
1089 ram 1.4 (setq initargs (append (slot-definition-initargs slotd) initargs))
1090     (let ((slotd-type (slot-definition-type slotd)))
1091 pmai 1.32 (setq type (cond ((eq type t) slotd-type)
1092 ram 1.4 ((*subtypep type slotd-type) type)
1093 ram 1.6 (t `(and ,type ,slotd-type)))))))
1094 wlott 1.1 (list :name name
1095     :initform initform
1096     :initfunction initfunction
1097     :initargs initargs
1098     :allocation allocation
1099 pmai 1.39 :allocation-class allocation-class
1100 ram 1.4 :type type
1101 ram 1.6 :class class)))
1102 wlott 1.1
1103 ram 1.6 (defmethod compute-effective-slot-definition-initargs :around
1104     ((class structure-class) direct-slotds)
1105     (let ((slotd (car direct-slotds)))
1106     (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
1107     :internal-reader-function (slot-definition-internal-reader-function slotd)
1108     :internal-writer-function (slot-definition-internal-writer-function slotd)
1109     (call-next-method))))
1110 wlott 1.1
1111     ;;;
1112     ;;; NOTE: For bootstrapping considerations, these can't use make-instance
1113     ;;; to make the method object. They have to use make-a-method which
1114     ;;; is a specially bootstrapped mechanism for making standard methods.
1115     ;;;
1116 ram 1.6 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
1117     (declare (ignore direct-slot initargs))
1118     (find-class 'standard-reader-method))
1119 wlott 1.1
1120 ram 1.6 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
1121     (add-method generic-function
1122     (make-a-method 'standard-reader-method
1123     ()
1124     (list (or (class-name class) 'object))
1125     (list class)
1126     (make-reader-method-function class slot-name)
1127     "automatically generated reader method"
1128     slot-name)))
1129 wlott 1.1
1130 ram 1.6 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
1131 ram 1.5 (declare (ignore direct-slot initargs))
1132 ram 1.6 (find-class 'standard-writer-method))
1133 ram 1.5
1134 ram 1.6 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
1135     (add-method generic-function
1136     (make-a-method 'standard-writer-method
1137     ()
1138     (list 'new-value (or (class-name class) 'object))
1139     (list *the-class-t* class)
1140     (make-writer-method-function class slot-name)
1141     "automatically generated writer method"
1142     slot-name)))
1143 ram 1.5
1144 ram 1.6 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
1145     (add-method generic-function
1146     (make-a-method 'standard-boundp-method
1147     ()
1148     (list (or (class-name class) 'object))
1149     (list class)
1150     (make-boundp-method-function class slot-name)
1151     "automatically generated boundp method"
1152     slot-name)))
1153 ram 1.5
1154 ram 1.4 (defmethod remove-reader-method ((class slot-class) generic-function)
1155 wlott 1.1 (let ((method (get-method generic-function () (list class) nil)))
1156 gerd 1.44 (when method
1157     (remove-method generic-function method))))
1158 wlott 1.1
1159 ram 1.4 (defmethod remove-writer-method ((class slot-class) generic-function)
1160 gerd 1.44 (let ((method (get-method generic-function ()
1161     (list *the-class-t* class) nil)))
1162     (when method
1163     (remove-method generic-function method))))
1164 wlott 1.1
1165 ram 1.4 (defmethod remove-boundp-method ((class slot-class) generic-function)
1166     (let ((method (get-method generic-function () (list class) nil)))
1167 gerd 1.44 (when method
1168     (remove-method generic-function method))))
1169 ram 1.4
1170 wlott 1.1
1171     ;;;
1172     ;;; make-reader-method-function and make-write-method function are NOT part of
1173     ;;; the standard protocol. They are however useful, PCL makes uses makes use
1174     ;;; of them internally and documents them for PCL users.
1175     ;;;
1176     ;;; *** This needs work to make type testing by the writer functions which
1177     ;;; *** do type testing faster. The idea would be to have one constructor
1178     ;;; *** for each possible type test. In order to do this it would be nice
1179     ;;; *** to have help from inform-type-system-about-class and friends.
1180     ;;;
1181     ;;; *** There is a subtle bug here which is going to have to be fixed.
1182     ;;; *** Namely, the simplistic use of the template has to be fixed. We
1183     ;;; *** have to give the optimize-slot-value method the user might have
1184     ;;; *** defined for this metclass a chance to run.
1185     ;;;
1186 ram 1.6 (defmethod make-reader-method-function ((class slot-class) slot-name)
1187     (make-std-reader-method-function (class-name class) slot-name))
1188 wlott 1.1
1189 ram 1.6 (defmethod make-writer-method-function ((class slot-class) slot-name)
1190     (make-std-writer-method-function (class-name class) slot-name))
1191 ram 1.5
1192 ram 1.6 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1193     (make-std-boundp-method-function (class-name class) slot-name))
1194 ram 1.5
1195 wlott 1.1
1196     ;;;; inform-type-system-about-class
1197     ;;;
1198 pw 1.26 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1199 wlott 1.1 ;;; which PCL uses to *try* and tell the type system about class definitions.
1200     ;;; In a more fully integrated implementation of CLOS, the type system would
1201     ;;; know about class objects and class names in a more fundamental way and
1202     ;;; the mechanism used to inform the type system about new classes would be
1203     ;;; different.
1204     ;;;
1205     (defmethod inform-type-system-about-class ((class std-class) name)
1206 pw 1.26 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1207     ;; compiler warnings. Not otherwise needed in this implementation.
1208 gerd 1.44 (inform-type-system-about-std-class name)
1209     (set-class-translation class name))
1210    
1211     (defmethod inform-type-system-about-class ((class funcallable-standard-class)
1212     name)
1213     (set-class-translation class name))
1214 pw 1.26
1215 gerd 1.44 (defmethod inform-type-system-about-class ((class structure-class) name)
1216     (set-class-translation class name))
1217    
1218     (defmethod inform-type-system-about-class ((class condition-class) name)
1219     (set-class-translation class name))
1220 pw 1.26
1221 gerd 1.50 (defmethod inform-type-system-about-class ((class forward-referenced-class)
1222     name)
1223     (inform-type-system-about-std-class name)
1224     (set-class-translation class name))
1225    
1226 wlott 1.1
1227     (defmethod compatible-meta-class-change-p (class proto-new-class)
1228     (eq (class-of class) (class-of proto-new-class)))
1229    
1230 ram 1.4 (defmethod validate-superclass ((class class) (new-super class))
1231     (or (eq new-super *the-class-t*)
1232     (eq (class-of class) (class-of new-super))))
1233 wlott 1.1
1234 dtc 1.16 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1235     (let ((new-super-meta-class (class-of new-super)))
1236     (or (eq new-super-meta-class *the-class-std-class*)
1237     (eq (class-of class) new-super-meta-class))))
1238 ram 1.4
1239 wlott 1.1
1240     ;;;
1241 pmai 1.37 ;;; Force the flushing of caches by creating a new wrapper for CLASS,
1242     ;;; if necessary.
1243 wlott 1.1 ;;;
1244 pmai 1.37 ;;; If the LAYOUT-INVALID slot of CLASS's wrapper is
1245     ;;;
1246     ;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's
1247     ;;; nothing to do. The new wrapper has already been created.
1248     ;;;
1249     ;;; -- :INVALID, then it has been set to that value by a previous
1250     ;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's
1251     ;;; wrapper has been invalidated together with its subclasses. In
1252     ;;; this case, CLASS's caches must obviously be flushed, too, like
1253     ;;; S's. So, make a new wrapper for CLASS, and translate kernel's
1254     ;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later
1255     ;;; decide if it wants to make this (:OBSOLETE ...).
1256     ;;;
1257     ;;; -- NIL, then the wrapper is still valid, in which case we do
1258     ;;; the same as for :INVALID, but for the obviously slightly
1259     ;;; different reason.
1260 wlott 1.1 ;;;
1261     (defun force-cache-flushes (class)
1262 pmai 1.37 (let* ((owrapper (class-wrapper class)))
1263     (when (or (not (invalid-wrapper-p owrapper))
1264     (eq :invalid (kernel:layout-invalid owrapper)))
1265 ram 1.6 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1266     class)))
1267 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1268     (wrapper-instance-slots-layout owrapper))
1269     (setf (wrapper-class-slots nwrapper)
1270     (wrapper-class-slots owrapper))
1271 pmai 1.34 (with-pcl-lock
1272 pw 1.9 (update-lisp-class-layout class nwrapper)
1273 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1274 pmai 1.32 (invalidate-wrapper owrapper :flush nwrapper))))))
1275 wlott 1.1
1276     (defun flush-cache-trap (owrapper nwrapper instance)
1277     (declare (ignore owrapper))
1278 gerd 1.44 (cond ((std-instance-p instance)
1279     (setf (std-instance-wrapper instance) nwrapper))
1280     ((fsc-instance-p instance)
1281     (setf (fsc-instance-wrapper instance) nwrapper))
1282     (t
1283     (internal-error "Internal error."))))
1284 wlott 1.1
1285    
1286     ;;;
1287     ;;; make-instances-obsolete can be called by user code. It will cause the
1288     ;;; next access to the instance (as defined in 88-002R) to trap through the
1289     ;;; update-instance-for-redefined-class mechanism.
1290     ;;;
1291     (defmethod make-instances-obsolete ((class std-class))
1292 ram 1.6 (let* ((owrapper (class-wrapper class))
1293     (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1294     class)))
1295 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1296     (wrapper-instance-slots-layout owrapper))
1297     (setf (wrapper-class-slots nwrapper)
1298     (wrapper-class-slots owrapper))
1299 pmai 1.34 (with-pcl-lock
1300 pw 1.9 (update-lisp-class-layout class nwrapper)
1301 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1302 pmai 1.32 (invalidate-wrapper owrapper :obsolete nwrapper)
1303 ram 1.6 class)))
1304 wlott 1.1
1305     (defmethod make-instances-obsolete ((class symbol))
1306     (make-instances-obsolete (find-class class)))
1307    
1308    
1309     ;;;
1310     ;;; obsolete-instance-trap is the internal trap that is called when we see
1311     ;;; an obsolete instance. The times when it is called are:
1312     ;;; - when the instance is involved in method lookup
1313     ;;; - when attempting to access a slot of an instance
1314     ;;;
1315     ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1316     ;;; access macros.
1317     ;;;
1318     ;;; Of course these times when it is called are an internal implementation
1319     ;;; detail of PCL and are not part of the documented description of when the
1320     ;;; obsolete instance update happens. The documented description is as it
1321     ;;; appears in 88-002R.
1322     ;;;
1323     ;;; This has to return the new wrapper, so it counts on all the methods on
1324     ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1325     ;;; a little internal error checking to make sure that the traps are only
1326     ;;; happening when they should, and that the trap methods are computing
1327     ;;; apropriate new wrappers.
1328     ;;;
1329 pw 1.9
1330     ;;; obsolete-instance-trap might be called on structure instances
1331     ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1332     ;;; will not be able to fix the old instance, so it must signal an
1333     ;;; error. The hard part of this is that the error system and debugger
1334     ;;; might cause obsolete-instance-trap to be called again, so in that
1335     ;;; case, we have to return some reasonable wrapper, instead.
1336    
1337     (defvar *in-obsolete-instance-trap* nil)
1338 gerd 1.44
1339 pw 1.9 (defvar *the-wrapper-of-structure-object*
1340     (class-wrapper (find-class 'structure-object)))
1341    
1342     (define-condition obsolete-structure (error)
1343     ((datum :reader obsolete-structure-datum :initarg :datum))
1344     (:report
1345     (lambda (condition stream)
1346     ;; Don't try to print the structure, since it probably
1347     ;; won't work.
1348 gerd 1.44 (format stream "~@<Obsolete structure error in ~S ~
1349     for a structure of type ~S.~@:>"
1350 pw 1.9 (conditions::condition-function-name condition)
1351     (type-of (obsolete-structure-datum condition))))))
1352    
1353     (defun obsolete-instance-trap (owrapper nwrapper instance)
1354 pw 1.25 (if (not (pcl-instance-p instance))
1355 pw 1.9 (if *in-obsolete-instance-trap*
1356     *the-wrapper-of-structure-object*
1357     (let ((*in-obsolete-instance-trap* t))
1358     (error 'obsolete-structure :datum instance)))
1359     (let* ((class (wrapper-class* nwrapper))
1360     (copy (allocate-instance class)) ;??? allocate-instance ???
1361     (olayout (wrapper-instance-slots-layout owrapper))
1362     (nlayout (wrapper-instance-slots-layout nwrapper))
1363     (oslots (get-slots instance))
1364     (nslots (get-slots copy))
1365     (oclass-slots (wrapper-class-slots owrapper))
1366     (added ())
1367     (discarded ())
1368     (plist ()))
1369     ;; local --> local transfer
1370     ;; local --> shared discard
1371     ;; local --> -- discard
1372     ;; shared --> local transfer
1373     ;; shared --> shared discard
1374     ;; shared --> -- discard
1375     ;; -- --> local add
1376     ;; -- --> shared --
1377     ;;
1378     ;; Go through all the old local slots.
1379 pmai 1.32 ;;
1380     (loop for name in olayout and opos from 0
1381     as npos = (posq name nlayout)
1382     if npos do
1383 gerd 1.44 (setf (slot-ref nslots npos)
1384     (slot-ref oslots opos))
1385 pmai 1.32 else do
1386     (push name discarded)
1387 gerd 1.44 (unless (eq (slot-ref oslots opos) +slot-unbound+)
1388 pmai 1.32 (setf (getf plist name)
1389 gerd 1.44 (slot-ref oslots opos))))
1390 pw 1.9 ;;
1391     ;; Go through all the old shared slots.
1392     ;;
1393 pmai 1.32 (loop for (name . val) in oclass-slots
1394     for npos = (posq name nlayout)
1395     if npos do
1396 gerd 1.44 (setf (slot-ref nslots npos) val)
1397 pmai 1.32 else do
1398     (push name discarded)
1399 pmai 1.35 (unless (eq val +slot-unbound+)
1400 pmai 1.32 (setf (getf plist name) val)))
1401 pw 1.9 ;;
1402     ;; Go through all the new local slots to compute the added slots.
1403     ;;
1404     (dolist (nlocal nlayout)
1405     (unless (or (memq nlocal olayout)
1406     (assq nlocal oclass-slots))
1407     (push nlocal added)))
1408 wlott 1.1
1409 pw 1.9 (swap-wrappers-and-slots instance copy)
1410 wlott 1.1
1411 pw 1.9 (update-instance-for-redefined-class instance
1412     added
1413     discarded
1414     plist)
1415     nwrapper)))
1416 wlott 1.1
1417    
1418     ;;;
1419     ;;;
1420     ;;;
1421 pmai 1.29 (defun change-class-internal (instance new-class initargs)
1422 ram 1.6 (let* ((old-class (class-of instance))
1423 pw 1.9 (copy (allocate-instance new-class))
1424     (new-wrapper (get-wrapper copy))
1425 ram 1.6 (old-wrapper (class-wrapper old-class))
1426     (old-layout (wrapper-instance-slots-layout old-wrapper))
1427     (new-layout (wrapper-instance-slots-layout new-wrapper))
1428     (old-slots (get-slots instance))
1429 pw 1.9 (new-slots (get-slots copy))
1430 ram 1.6 (old-class-slots (wrapper-class-slots old-wrapper)))
1431    
1432 wlott 1.1 ;;
1433     ;; "The values of local slots specified by both the class Cto and
1434     ;; Cfrom are retained. If such a local slot was unbound, it remains
1435     ;; unbound."
1436 pmai 1.32 ;;
1437     (loop for new-slot in new-layout and new-position from 0
1438     for old-position = (posq new-slot old-layout)
1439     when old-position do
1440 gerd 1.44 (setf (slot-ref new-slots new-position)
1441     (slot-ref old-slots old-position)))
1442 wlott 1.1 ;;
1443     ;; "The values of slots specified as shared in the class Cfrom and
1444     ;; as local in the class Cto are retained."
1445     ;;
1446 pmai 1.32 (loop for (name . val) in old-class-slots
1447     for new-position = (posq name new-layout)
1448     when new-position do
1449 gerd 1.44 (setf (slot-ref new-slots new-position) val))
1450 wlott 1.1
1451     ;; Make the copy point to the old instance's storage, and make the
1452     ;; old instance point to the new storage.
1453 pw 1.9 (swap-wrappers-and-slots instance copy)
1454 wlott 1.1
1455 pmai 1.29 (apply #'update-instance-for-different-class copy instance initargs)
1456 wlott 1.1 instance))
1457    
1458     (defmethod change-class ((instance standard-object)
1459 pmai 1.29 (new-class standard-class)
1460     &rest initargs)
1461     (change-class-internal instance new-class initargs))
1462 wlott 1.1
1463 dtc 1.15 (defmethod change-class ((instance funcallable-standard-object)
1464 pmai 1.29 (new-class funcallable-standard-class)
1465     &rest initargs)
1466     (change-class-internal instance new-class initargs))
1467 dtc 1.17
1468     (defmethod change-class ((instance standard-object)
1469 pmai 1.29 (new-class funcallable-standard-class)
1470     &rest initargs)
1471     (declare (ignore initargs))
1472 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1473     because it isn't already an instance with metaclass ~S.~@:>"
1474 dtc 1.17 instance new-class 'standard-class))
1475    
1476     (defmethod change-class ((instance funcallable-standard-object)
1477 pmai 1.29 (new-class standard-class)
1478     &rest initargs)
1479     (declare (ignore initargs))
1480 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1481     because it isn't already an instance with metaclass ~S.~@:>"
1482 dtc 1.17 instance new-class 'funcallable-standard-class))
1483 wlott 1.1
1484 pmai 1.29 (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1485     (apply #'change-class instance (find-class new-class-name) initargs))
1486 wlott 1.1
1487    
1488    
1489     ;;;
1490     ;;; The metaclass BUILT-IN-CLASS
1491     ;;;
1492     ;;; This metaclass is something of a weird creature. By this point, all
1493     ;;; instances of it which will exist have been created, and no instance
1494     ;;; is ever created by calling MAKE-INSTANCE.
1495     ;;;
1496     ;;; But, there are other parts of the protcol we must follow and those
1497     ;;; definitions appear here.
1498     ;;;
1499     (defmethod shared-initialize :before
1500     ((class built-in-class) slot-names &rest initargs)
1501 ram 1.5 (declare (ignore slot-names initargs))
1502 gerd 1.44 (error "Attempt to initialize or reinitialize a built-in class."))
1503 wlott 1.1
1504 ram 1.6 (defmethod class-direct-slots ((class built-in-class)) ())
1505     (defmethod class-slots ((class built-in-class)) ())
1506     (defmethod class-direct-default-initargs ((class built-in-class)) ())
1507     (defmethod class-default-initargs ((class built-in-class)) ())
1508    
1509 ram 1.4 (defmethod validate-superclass ((c class) (s built-in-class))
1510 gerd 1.44 (or (eq s *the-class-t*)
1511     (eq s *the-class-stream*)))
1512 wlott 1.1
1513 ram 1.4
1514 wlott 1.1
1515     ;;;
1516     ;;;
1517     ;;;
1518    
1519 gerd 1.44 (macrolet ((frob (method)
1520     `(defmethod ,method ((class forward-referenced-class))
1521     (declare (ignore class))
1522     ())))
1523     (frob class-direct-slots)
1524     (frob class-direct-default-initargs))
1525    
1526     (macrolet ((frob (method)
1527     `(defmethod ,method ((class forward-referenced-class))
1528     (error "~@<~S called for forward referenced class ~S.~@:>"
1529     ',method class))))
1530     (frob class-default-initargs)
1531     (frob class-precedence-list)
1532     (frob class-slots))
1533    
1534 ram 1.4 (defmethod validate-superclass ((c slot-class)
1535 dtc 1.16 (f forward-referenced-class))
1536 pmai 1.32 t)
1537 wlott 1.1
1538    
1539     ;;;
1540     ;;;
1541     ;;;
1542    
1543     (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1544     (pushnew dependent (plist-value metaobject 'dependents)))
1545    
1546     (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1547     (setf (plist-value metaobject 'dependents)
1548     (delete dependent (plist-value metaobject 'dependents))))
1549    
1550     (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1551     (dolist (dependent (plist-value metaobject 'dependents))
1552 ram 1.2 (funcall function dependent)))
1553 ram 1.4
1554 gerd 1.44
1555     ;;;
1556     ;;; Conditions
1557     ;;;
1558 gerd 1.45 (defmethod class-direct-slots ((class condition-class)) ())
1559     (defmethod class-slots ((class condition-class)) ())
1560     (defmethod class-default-initargs ((class condition-class)) ())
1561     (defmethod class-direct-default-initargs ((class condition-class)) ())
1562    
1563 gerd 1.44 (defmethod shared-initialize :after ((class condition-class) slot-names
1564     &key direct-superclasses)
1565     (declare (ignore slot-names))
1566     (let ((kernel-class (kernel::find-class (class-name class))))
1567     (with-slots (wrapper class-precedence-list prototype predicate-name
1568     (direct-supers direct-superclasses))
1569     class
1570 gerd 1.50 (setf (slot-value class 'finalized-p) t)
1571 gerd 1.44 (setf (kernel:%class-pcl-class kernel-class) class)
1572     (setq direct-supers direct-superclasses)
1573     (setq wrapper (kernel:%class-layout kernel-class))
1574     (setq class-precedence-list (compute-class-precedence-list class))
1575     (setq prototype (make-condition (class-name class)))
1576     (add-direct-subclasses class direct-superclasses)
1577     (setq predicate-name (make-class-predicate-name (class-name class)))
1578     (make-class-predicate class predicate-name))))
1579    

  ViewVC Help
Powered by ViewVC 1.1.5