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

  ViewVC Help
Powered by ViewVC 1.1.5