/[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.43.2.4 - (hide annotations)
Thu Mar 20 23:41:00 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.43.2.3: +23 -1 lines
* std-class.lisp (inform-type-system-about-class)
(shared-initialize :after): New methods for condition-class.

* macros.lisp (find-class-from-cell): Test both structure-type-p
and condition-type-p.  Use ensure-non-standard-class.

* low.lisp (structure-type-p): Return false for conditions.
(condition-type-p): New function.

* env.lisp (coerce-to-pcl-class, make-instance, change-class)
(frob): Remove methods specializing on kernel::class.

* defs.lisp (specializer-from-type): Use
ensure-non-standard-class.
(condition-class): New metaclass.

* cmucl-documentation.lisp (setf documentation): Test
both structure-type-p and condition-type-p.

* cache.lisp (wrapper-class*): Call ensure-non-standard-class.
(raise-metatype): Handle condition-class.

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

  ViewVC Help
Powered by ViewVC 1.1.5