/[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.32 - (hide annotations)
Mon Aug 26 02:23:15 2002 UTC (11 years, 8 months ago) by pmai
Branch: MAIN
Changes since 1.31: +124 -128 lines
Huge patch by Gerd Moellmann that removes PCL::ITERATE and PCL::GATHER*
in favor of normal CL constructs.  In a similar vein to SBCL, this patch
also replaces all uses of #'(lambda ...) by just (lambda ...), and
removes now-dated looking quotes in front of self-evaluating objects,
like keywords and t/nil.  The patch has been slightly frobbed by me,
to correct a couple of slight oversights, and make more effective use
of the loop facility in a number of places.
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.32 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.32 2002/08/26 02:23:15 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     ,(load-truename))
331     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.31 (labels ((program-error (format-control &rest args)
378     (error 'kernel:simple-program-error
379     :format-control format-control
380     :format-arguments args))
381     (fix-super (s)
382     (cond ((classp s) s)
383     ((not (legal-class-name-p s))
384     (program-error "~S is not a class or a legal ~
385     class name." s))
386     (t
387     (or (find-class s nil)
388     (setf (find-class s)
389     (make-instance 'forward-referenced-class
390     :name s)))))))
391     ;;
392     ;; CLHS: signal PROGRAM-ERROR, if
393     ;; (a) there are any duplicate slot names
394     ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
395     ;; :DOCUMENTATION appears more than one in a single slot description.
396     (loop for (slot . more) on (getf initargs :direct-slots)
397     for slot-name = (getf slot :name)
398     if (some (lambda (s) (eq slot-name (getf s :name))) more) do
399     (program-error "More than one direct slot with name ~S."
400     slot-name)
401     else do
402     (loop for (option value . more) on slot by #'cddr
403     when (and (member option '(:allocation :type :initform
404     :documentation))
405     (not (eq unsupplied
406     (getf more option unsupplied)))) do
407     (program-error "Duplicate slot option ~S for slot ~S."
408     option slot-name)))
409     ;;
410     ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
411     ;; appears more than once in :DEFAULT-INITARGS class option.
412     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
413     for name = (car initarg)
414     when (some (lambda (a) (eq (car a) name)) more) do
415     (program-error "Duplicate initialization argument ~
416     name ~S in :default-initargs of class ~A."
417     name class))
418     ;;
419 wlott 1.1 (loop (unless (remf initargs :metaclass) (return)))
420     (loop (unless (remf initargs :direct-superclasses) (return)))
421     (values meta
422 pmai 1.28 (nconc
423     (when (neq supplied-supers unsupplied)
424     (list
425     :direct-superclasses
426     (mapcar #'fix-super supplied-supers)))
427     initargs)))))
428 wlott 1.1
429    
430     ;;;
431     ;;;
432     ;;;
433 ram 1.6 #|| ; since it doesn't do anything
434 wlott 1.1 (defmethod shared-initialize :before ((class std-class)
435     slot-names
436 ram 1.6 &key direct-superclasses)
437 wlott 1.1 (declare (ignore slot-names))
438 ram 1.6 ;; *** error checking
439     )
440     ||#
441    
442 wlott 1.1 (defmethod shared-initialize :after
443     ((class std-class)
444     slot-names
445 ram 1.2 &key (direct-superclasses nil direct-superclasses-p)
446     (direct-slots nil direct-slots-p)
447 ram 1.4 (direct-default-initargs nil direct-default-initargs-p)
448     (predicate-name nil predicate-name-p))
449 wlott 1.1 (declare (ignore slot-names))
450 pmai 1.28 (cond ((or direct-superclasses-p
451     (null (slot-value class 'direct-superclasses)))
452 dtc 1.17 (setq direct-superclasses
453     (or direct-superclasses
454     (list (if (funcallable-standard-class-p class)
455     *the-class-funcallable-standard-object*
456     *the-class-standard-object*))))
457     (dolist (superclass direct-superclasses)
458     (unless (validate-superclass class superclass)
459     (error "The class ~S was specified as a~%
460     super-class of the class ~S;~%~
461     but the meta-classes ~S and~%~S are incompatible.~@
462     Define a method for ~S to avoid this error."
463     superclass class (class-of superclass) (class-of class)
464     'validate-superclass)))
465     (setf (slot-value class 'direct-superclasses) direct-superclasses))
466     (t
467     (setq direct-superclasses (slot-value class 'direct-superclasses))))
468 ram 1.2 (setq direct-slots
469     (if direct-slots-p
470     (setf (slot-value class 'direct-slots)
471 pmai 1.32 (mapcar (lambda (pl) (make-direct-slotd class pl)) direct-slots))
472 ram 1.2 (slot-value class 'direct-slots)))
473     (if direct-default-initargs-p
474 ram 1.6 (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
475     (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
476 wlott 1.1 (setf (plist-value class 'class-slot-cells)
477 pmai 1.32 (let ((collected ()))
478     (dolist (dslotd direct-slots (nreverse collected))
479 ram 1.4 (when (eq (slot-definition-allocation dslotd) class)
480     (let ((initfunction (slot-definition-initfunction dslotd)))
481 pmai 1.32 (push (cons (slot-definition-name dslotd)
482     (if initfunction
483     (funcall initfunction)
484     *slot-unbound*))
485     collected))))))
486 ram 1.6 (setq predicate-name (if predicate-name-p
487     (setf (slot-value class 'predicate-name)
488     (car predicate-name))
489     (or (slot-value class 'predicate-name)
490     (setf (slot-value class 'predicate-name)
491     (make-class-predicate-name (class-name class))))))
492 wlott 1.1 (add-direct-subclasses class direct-superclasses)
493 ram 1.6 (update-class class nil)
494     (make-class-predicate class predicate-name)
495     (add-slot-accessors class direct-slots))
496 wlott 1.1
497 ram 1.6 (defmethod shared-initialize :before ((class class) slot-names &key name)
498     (declare (ignore slot-names name))
499 ram 1.4 (setf (slot-value class 'type) `(class ,class))
500     (setf (slot-value class 'class-eq-specializer)
501     (make-instance 'class-eq-specializer :class class)))
502    
503 pw 1.22 (defmethod reinitialize-instance :before ((class slot-class)
504     &key direct-superclasses)
505     (remove-direct-subclasses class direct-superclasses)
506 wlott 1.1 (remove-slot-accessors class (class-direct-slots class)))
507    
508 ram 1.6 (defmethod reinitialize-instance :after ((class slot-class)
509 wlott 1.1 &rest initargs
510     &key)
511     (map-dependents class
512 pmai 1.32 (lambda (dependent)
513     (apply #'update-dependent class dependent initargs))))
514 ram 1.4
515 ram 1.6 (defmethod shared-initialize :after
516     ((class structure-class)
517     slot-names
518     &key (direct-superclasses nil direct-superclasses-p)
519     (direct-slots nil direct-slots-p)
520     direct-default-initargs
521     (predicate-name nil predicate-name-p))
522     (declare (ignore slot-names direct-default-initargs))
523     (if direct-superclasses-p
524     (setf (slot-value class 'direct-superclasses)
525     (or direct-superclasses
526     (setq direct-superclasses
527     (and (not (eq (class-name class) 'structure-object))
528     (list *the-class-structure-object*)))))
529     (setq direct-superclasses (slot-value class 'direct-superclasses)))
530     (let* ((name (class-name class))
531     (from-defclass-p (slot-value class 'from-defclass-p))
532     (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
533     (if direct-slots-p
534     (setf (slot-value class 'direct-slots)
535     (setq direct-slots
536 pmai 1.32 (mapcar (lambda (pl)
537     (when defstruct-p
538     (let* ((slot-name (getf pl :name))
539     (acc-name (format nil "~s structure class ~a"
540     name slot-name))
541     (accessor (intern acc-name)))
542     (setq pl (list* :defstruct-accessor-symbol accessor
543     pl))))
544     (make-direct-slotd class pl))
545 ram 1.6 direct-slots)))
546     (setq direct-slots (slot-value class 'direct-slots)))
547     (when defstruct-p
548     (let* ((include (car (slot-value class 'direct-superclasses)))
549     (conc-name (intern (format nil "~s structure class " name)))
550     (constructor (intern (format nil "~a constructor" conc-name)))
551     (defstruct `(defstruct (,name
552     ,@(when include
553     `((:include ,(class-name include))))
554     (:predicate nil)
555     (:conc-name ,conc-name)
556     (:constructor ,constructor ()))
557 pmai 1.32 ,@(mapcar (lambda (slot)
558     `(,(slot-definition-name slot)
559     *slot-unbound*))
560 ram 1.6 direct-slots)))
561 pmai 1.32 (reader-names (mapcar (lambda (slotd)
562     (intern (format nil "~A~A reader" conc-name
563     (slot-definition-name slotd))))
564 ram 1.6 direct-slots))
565 pmai 1.32 (writer-names (mapcar (lambda (slotd)
566     (intern (format nil "~A~A writer" conc-name
567     (slot-definition-name slotd))))
568 ram 1.6 direct-slots))
569     (readers-init
570 pmai 1.32 (mapcar (lambda (slotd reader-name)
571     (let ((accessor
572     (slot-definition-defstruct-accessor-symbol slotd)))
573     `(defun ,reader-name (obj)
574     (declare (type ,name obj))
575     (,accessor obj))))
576 ram 1.6 direct-slots reader-names))
577     (writers-init
578 pmai 1.32 (mapcar (lambda (slotd writer-name)
579     (let ((accessor
580     (slot-definition-defstruct-accessor-symbol slotd)))
581     `(defun ,writer-name (nv obj)
582     (declare (type ,name obj))
583     (setf (,accessor obj) nv))))
584 ram 1.6 direct-slots writer-names))
585     (defstruct-form
586     `(progn
587     ,defstruct
588 pw 1.27 ,@readers-init ,@writers-init)))
589 ram 1.6 (unless (structure-type-p name) (eval defstruct-form))
590 pmai 1.32 (mapc (lambda (dslotd reader-name writer-name)
591     (let* ((reader (gdefinition reader-name))
592     (writer (when (fboundp writer-name)
593     (gdefinition writer-name))))
594     (setf (slot-value dslotd 'internal-reader-function) reader)
595     (setf (slot-value dslotd 'internal-writer-function) writer)))
596 ram 1.6 direct-slots reader-names writer-names)
597     (setf (slot-value class 'defstruct-form) defstruct-form)
598     (setf (slot-value class 'defstruct-constructor) constructor))))
599     (add-direct-subclasses class direct-superclasses)
600     (setf (slot-value class 'class-precedence-list)
601     (compute-class-precedence-list class))
602     (setf (slot-value class 'slots) (compute-slots class))
603 pw 1.25 (let ((lclass (lisp:find-class (class-name class))))
604 pw 1.9 (setf (kernel:class-pcl-class lclass) class)
605     (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
606 ram 1.6 (update-pv-table-cache-info class)
607     (setq predicate-name (if predicate-name-p
608     (setf (slot-value class 'predicate-name)
609     (car predicate-name))
610     (or (slot-value class 'predicate-name)
611     (setf (slot-value class 'predicate-name)
612     (make-class-predicate-name (class-name class))))))
613     (make-class-predicate class predicate-name)
614     (add-slot-accessors class direct-slots))
615 ram 1.4
616 ram 1.6 (defmethod direct-slot-definition-class ((class structure-class) initargs)
617     (declare (ignore initargs))
618     (find-class 'structure-direct-slot-definition))
619    
620     (defmethod finalize-inheritance ((class structure-class))
621     nil) ; always finalized
622 wlott 1.1
623     (defun add-slot-accessors (class dslotds)
624     (fix-slot-accessors class dslotds 'add))
625    
626     (defun remove-slot-accessors (class dslotds)
627     (fix-slot-accessors class dslotds 'remove))
628    
629     (defun fix-slot-accessors (class dslotds add/remove)
630 ram 1.6 (flet ((fix (gfspec name r/w)
631 wlott 1.1 (let ((gf (ensure-generic-function gfspec)))
632     (case r/w
633     (r (if (eq add/remove 'add)
634 ram 1.6 (add-reader-method class gf name)
635 wlott 1.1 (remove-reader-method class gf)))
636     (w (if (eq add/remove 'add)
637 ram 1.6 (add-writer-method class gf name)
638 wlott 1.1 (remove-writer-method class gf)))))))
639     (dolist (dslotd dslotds)
640 ram 1.6 (let ((slot-name (slot-definition-name dslotd)))
641     (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
642     (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
643 wlott 1.1
644    
645     (defun add-direct-subclasses (class new)
646     (dolist (n new)
647     (unless (memq class (class-direct-subclasses class))
648     (add-direct-subclass n class))))
649    
650     (defun remove-direct-subclasses (class new)
651     (let ((old (class-direct-superclasses class)))
652     (dolist (o (set-difference old new))
653     (remove-direct-subclass o class))))
654    
655    
656     ;;;
657     ;;;
658     ;;;
659     (defmethod finalize-inheritance ((class std-class))
660     (update-class class t))
661    
662    
663 ram 1.6 (defun class-has-a-forward-referenced-superclass-p (class)
664     (or (forward-referenced-class-p class)
665     (some #'class-has-a-forward-referenced-superclass-p
666     (class-direct-superclasses class))))
667 ram 1.4
668 wlott 1.1 ;;;
669 ram 1.4 ;;; Called by :after shared-initialize whenever a class is initialized or
670     ;;; reinitialized. The class may or may not be finalized.
671 wlott 1.1 ;;;
672     (defun update-class (class finalizep)
673 ram 1.6 (when (or finalizep (class-finalized-p class)
674     (not (class-has-a-forward-referenced-superclass-p class)))
675 ram 1.4 (update-cpl class (compute-class-precedence-list class))
676 ram 1.6 (update-slots class (compute-slots class))
677 ram 1.4 (update-gfs-of-class class)
678     (update-inits class (compute-default-initargs class))
679 phg 1.7 (update-make-instance-function-table class))
680 wlott 1.1 (unless finalizep
681     (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
682    
683     (defun update-cpl (class cpl)
684 dtc 1.13 (if (class-finalized-p class)
685     (unless (equal (class-precedence-list class) cpl)
686     ;; Need to have the cpl setup before update-lisp-class-layout
687     ;; is called on CMUCL.
688     (setf (slot-value class 'class-precedence-list) cpl)
689     (force-cache-flushes class))
690     (setf (slot-value class 'class-precedence-list) cpl))
691 ram 1.4 (update-class-can-precede-p cpl))
692 wlott 1.1
693 ram 1.4 (defun update-class-can-precede-p (cpl)
694     (when cpl
695 ram 1.6 (let ((first (car cpl)))
696 ram 1.4 (dolist (c (cdr cpl))
697 ram 1.6 (pushnew c (slot-value first 'can-precede-list))))
698 ram 1.4 (update-class-can-precede-p (cdr cpl))))
699    
700     (defun class-can-precede-p (class1 class2)
701 ram 1.6 (member class2 (class-can-precede-list class1)))
702 ram 1.4
703 ram 1.6 (defun update-slots (class eslotds)
704 ram 1.4 (let ((instance-slots ())
705     (class-slots ()))
706     (dolist (eslotd eslotds)
707     (let ((alloc (slot-definition-allocation eslotd)))
708     (cond ((eq alloc :instance) (push eslotd instance-slots))
709     ((classp alloc) (push eslotd class-slots)))))
710 ram 1.6 ;;
711     ;; If there is a change in the shape of the instances then the
712     ;; old class is now obsolete.
713     ;;
714     (let* ((nlayout (mapcar #'slot-definition-name
715     (sort instance-slots #'< :key #'slot-definition-location)))
716     (nslots (length nlayout))
717     (nwrapper-class-slots (compute-class-slots class-slots))
718     (owrapper (class-wrapper class))
719     (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
720     (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
721     (nwrapper
722     (cond ((null owrapper)
723     (make-wrapper nslots class))
724     ((and (equal nlayout olayout)
725 pmai 1.32 (every (lambda (o n) (eq (car o) (car n)))
726     owrapper-class-slots nwrapper-class-slots))
727 ram 1.6 owrapper)
728     (t
729     ;;
730     ;; This will initialize the new wrapper to have the same
731     ;; state as the old wrapper. We will then have to change
732     ;; that. This may seem like wasted work (it is), but the
733     ;; spec requires that we call make-instances-obsolete.
734     ;;
735     (make-instances-obsolete class)
736     (class-wrapper class)))))
737 pw 1.9
738 ram 1.6 (with-slots (wrapper slots) class
739 pw 1.9 (update-lisp-class-layout class nwrapper)
740 ram 1.6 (setf slots eslotds
741     (wrapper-instance-slots-layout nwrapper) nlayout
742     (wrapper-class-slots nwrapper) nwrapper-class-slots
743     (wrapper-no-of-instance-slots nwrapper) nslots
744     wrapper nwrapper))
745 pw 1.9
746 ram 1.6 (unless (eq owrapper nwrapper)
747     (update-pv-table-cache-info class)))))
748 wlott 1.1
749 ram 1.6 (defun compute-class-slots (eslotds)
750 pmai 1.32 (loop for eslotd in eslotds
751     for name = (slot-definition-name eslotd)
752     and allocation = (slot-definition-allocation eslotd)
753     collect (assoc name (class-slot-cells allocation))))
754 wlott 1.1
755 ram 1.6 (defun compute-layout (cpl instance-eslotds)
756 pmai 1.32 (let* ((names (loop for eslotd in instance-eslotds
757     when (eq (slot-definition-allocation eslotd) :instance)
758     collect (slot-definition-name eslotd)))
759 wlott 1.1 (order ()))
760     (labels ((rwalk (tail)
761     (when tail
762     (rwalk (cdr tail))
763 ram 1.6 (dolist (ss (class-slots (car tail)))
764 ram 1.4 (let ((n (slot-definition-name ss)))
765 ram 1.6 (when (member n names)
766 wlott 1.1 (setq order (cons n order)
767     names (remove n names))))))))
768 ram 1.6 (rwalk (if (slot-boundp (car cpl) 'slots)
769     cpl
770     (cdr cpl)))
771     (reverse (append names order)))))
772 wlott 1.1
773 ram 1.4 (defun update-gfs-of-class (class)
774 ram 1.6 (when (and (class-finalized-p class)
775     (let ((cpl (class-precedence-list class)))
776     (or (member *the-class-slot-class* cpl)
777     (member *the-class-standard-effective-slot-definition* cpl))))
778 ram 1.4 (let ((gf-table (make-hash-table :test 'eq)))
779     (labels ((collect-gfs (class)
780     (dolist (gf (specializer-direct-generic-functions class))
781     (setf (gethash gf gf-table) t))
782     (mapc #'collect-gfs (class-direct-superclasses class))))
783     (collect-gfs class)
784 pmai 1.32 (maphash (lambda (gf ignore)
785     (declare (ignore ignore))
786     (update-gf-dfun class gf))
787 ram 1.4 gf-table)))))
788 wlott 1.1
789     (defun update-inits (class inits)
790 ram 1.6 (setf (plist-value class 'default-initargs) inits))
791 wlott 1.1
792    
793     ;;;
794     ;;;
795     ;;;
796 ram 1.4 (defmethod compute-default-initargs ((class slot-class))
797     (let ((cpl (class-precedence-list class))
798     (direct (class-direct-default-initargs class)))
799     (labels ((walk (tail)
800     (if (null tail)
801     nil
802     (let ((c (pop tail)))
803     (append (if (eq c class)
804     direct
805     (class-direct-default-initargs c))
806     (walk tail))))))
807     (let ((initargs (walk cpl)))
808     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
809 wlott 1.1
810    
811     ;;;
812     ;;; Protocols for constructing direct and effective slot definitions.
813     ;;;
814     ;;;
815     ;;;
816     ;;;
817     (defmethod direct-slot-definition-class ((class std-class) initargs)
818     (declare (ignore initargs))
819     (find-class 'standard-direct-slot-definition))
820    
821 ram 1.6 (defun make-direct-slotd (class initargs)
822     (let ((initargs (list* :class class initargs)))
823     (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
824    
825 wlott 1.1 ;;;
826     ;;;
827     ;;;
828 ram 1.4 (defmethod compute-slots ((class std-class))
829 wlott 1.1 ;;
830     ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
831     ;; for each different slot name we find in our superclasses. Each
832     ;; call receives the class and a list of the dslotds with that name.
833     ;; The list is in most-specific-first order.
834     ;;
835     (let ((name-dslotds-alist ()))
836 ram 1.6 (dolist (c (class-precedence-list class))
837 ram 1.4 (let ((dslotds (class-direct-slots c)))
838     (dolist (d dslotds)
839     (let* ((name (slot-definition-name d))
840     (entry (assq name name-dslotds-alist)))
841     (if entry
842     (push d (cdr entry))
843     (push (list name d) name-dslotds-alist))))))
844 pmai 1.32 (mapcar (lambda (direct)
845     (compute-effective-slot-definition class
846     (nreverse (cdr direct))))
847 ram 1.4 name-dslotds-alist)))
848 wlott 1.1
849 ram 1.4 (defmethod compute-slots :around ((class std-class))
850     (let ((eslotds (call-next-method))
851 ram 1.6 (cpl (class-precedence-list class))
852 ram 1.4 (instance-slots ())
853 ram 1.6 (class-slots ()))
854 ram 1.4 (dolist (eslotd eslotds)
855     (let ((alloc (slot-definition-allocation eslotd)))
856     (cond ((eq alloc :instance) (push eslotd instance-slots))
857 ram 1.6 ((classp alloc) (push eslotd class-slots)))))
858     (let ((nlayout (compute-layout cpl instance-slots)))
859 ram 1.4 (dolist (eslotd instance-slots)
860     (setf (slot-definition-location eslotd)
861 ram 1.6 (position (slot-definition-name eslotd) nlayout))))
862 ram 1.4 (dolist (eslotd class-slots)
863     (setf (slot-definition-location eslotd)
864 ram 1.6 (assoc (slot-definition-name eslotd)
865     (class-slot-cells (slot-definition-allocation eslotd)))))
866     (mapc #'initialize-internal-slot-functions eslotds)
867 ram 1.4 eslotds))
868    
869 ram 1.6 (defmethod compute-slots ((class structure-class))
870 pmai 1.32 (mapcan (lambda (superclass)
871     (mapcar (lambda (dslotd)
872     (compute-effective-slot-definition class (list dslotd)))
873     (class-direct-slots superclass)))
874 ram 1.6 (reverse (slot-value class 'class-precedence-list))))
875 ram 1.4
876 ram 1.6 (defmethod compute-slots :around ((class structure-class))
877     (let ((eslotds (call-next-method)))
878     (mapc #'initialize-internal-slot-functions eslotds)
879     eslotds))
880    
881     (defmethod compute-effective-slot-definition ((class slot-class) dslotds)
882 wlott 1.1 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
883 ram 1.6 (class (effective-slot-definition-class class initargs)))
884     (apply #'make-instance class initargs)))
885 wlott 1.1
886     (defmethod effective-slot-definition-class ((class std-class) initargs)
887     (declare (ignore initargs))
888 ram 1.6 (find-class 'standard-effective-slot-definition))
889 wlott 1.1
890 ram 1.6 (defmethod effective-slot-definition-class ((class structure-class) initargs)
891     (declare (ignore initargs))
892     (find-class 'structure-effective-slot-definition))
893    
894 ram 1.4 (defmethod compute-effective-slot-definition-initargs
895     ((class slot-class) direct-slotds)
896 wlott 1.1 (let* ((name nil)
897     (initfunction nil)
898     (initform nil)
899     (initargs nil)
900     (allocation nil)
901     (type t)
902     (namep nil)
903     (initp nil)
904 ram 1.6 (allocp nil))
905 wlott 1.1
906     (dolist (slotd direct-slotds)
907     (when slotd
908     (unless namep
909 ram 1.4 (setq name (slot-definition-name slotd)
910 wlott 1.1 namep t))
911     (unless initp
912 ram 1.4 (when (slot-definition-initfunction slotd)
913 ram 1.6 (setq initform (slot-definition-initform slotd)
914     initfunction (slot-definition-initfunction slotd)
915 wlott 1.1 initp t)))
916     (unless allocp
917 ram 1.4 (setq allocation (slot-definition-allocation slotd)
918 wlott 1.1 allocp t))
919 ram 1.4 (setq initargs (append (slot-definition-initargs slotd) initargs))
920     (let ((slotd-type (slot-definition-type slotd)))
921 pmai 1.32 (setq type (cond ((eq type t) slotd-type)
922 ram 1.4 ((*subtypep type slotd-type) type)
923 ram 1.6 (t `(and ,type ,slotd-type)))))))
924 wlott 1.1 (list :name name
925     :initform initform
926     :initfunction initfunction
927     :initargs initargs
928     :allocation allocation
929 ram 1.4 :type type
930 ram 1.6 :class class)))
931 wlott 1.1
932 ram 1.6 (defmethod compute-effective-slot-definition-initargs :around
933     ((class structure-class) direct-slotds)
934     (let ((slotd (car direct-slotds)))
935     (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
936     :internal-reader-function (slot-definition-internal-reader-function slotd)
937     :internal-writer-function (slot-definition-internal-writer-function slotd)
938     (call-next-method))))
939 wlott 1.1
940     ;;;
941     ;;; NOTE: For bootstrapping considerations, these can't use make-instance
942     ;;; to make the method object. They have to use make-a-method which
943     ;;; is a specially bootstrapped mechanism for making standard methods.
944     ;;;
945 ram 1.6 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
946     (declare (ignore direct-slot initargs))
947     (find-class 'standard-reader-method))
948 wlott 1.1
949 ram 1.6 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
950     (add-method generic-function
951     (make-a-method 'standard-reader-method
952     ()
953     (list (or (class-name class) 'object))
954     (list class)
955     (make-reader-method-function class slot-name)
956     "automatically generated reader method"
957     slot-name)))
958 wlott 1.1
959 ram 1.6 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
960 ram 1.5 (declare (ignore direct-slot initargs))
961 ram 1.6 (find-class 'standard-writer-method))
962 ram 1.5
963 ram 1.6 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
964     (add-method generic-function
965     (make-a-method 'standard-writer-method
966     ()
967     (list 'new-value (or (class-name class) 'object))
968     (list *the-class-t* class)
969     (make-writer-method-function class slot-name)
970     "automatically generated writer method"
971     slot-name)))
972 ram 1.5
973 ram 1.6 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
974     (add-method generic-function
975     (make-a-method 'standard-boundp-method
976     ()
977     (list (or (class-name class) 'object))
978     (list class)
979     (make-boundp-method-function class slot-name)
980     "automatically generated boundp method"
981     slot-name)))
982 ram 1.5
983 ram 1.4 (defmethod remove-reader-method ((class slot-class) generic-function)
984 wlott 1.1 (let ((method (get-method generic-function () (list class) nil)))
985     (when method (remove-method generic-function method))))
986    
987 ram 1.4 (defmethod remove-writer-method ((class slot-class) generic-function)
988 wlott 1.1 (let ((method
989     (get-method generic-function () (list *the-class-t* class) nil)))
990     (when method (remove-method generic-function method))))
991    
992 ram 1.4 (defmethod remove-boundp-method ((class slot-class) generic-function)
993     (let ((method (get-method generic-function () (list class) nil)))
994     (when method (remove-method generic-function method))))
995    
996 wlott 1.1
997     ;;;
998     ;;; make-reader-method-function and make-write-method function are NOT part of
999     ;;; the standard protocol. They are however useful, PCL makes uses makes use
1000     ;;; of them internally and documents them for PCL users.
1001     ;;;
1002     ;;; *** This needs work to make type testing by the writer functions which
1003     ;;; *** do type testing faster. The idea would be to have one constructor
1004     ;;; *** for each possible type test. In order to do this it would be nice
1005     ;;; *** to have help from inform-type-system-about-class and friends.
1006     ;;;
1007     ;;; *** There is a subtle bug here which is going to have to be fixed.
1008     ;;; *** Namely, the simplistic use of the template has to be fixed. We
1009     ;;; *** have to give the optimize-slot-value method the user might have
1010     ;;; *** defined for this metclass a chance to run.
1011     ;;;
1012 ram 1.6 (defmethod make-reader-method-function ((class slot-class) slot-name)
1013     (make-std-reader-method-function (class-name class) slot-name))
1014 wlott 1.1
1015 ram 1.6 (defmethod make-writer-method-function ((class slot-class) slot-name)
1016     (make-std-writer-method-function (class-name class) slot-name))
1017 ram 1.5
1018 ram 1.6 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1019     (make-std-boundp-method-function (class-name class) slot-name))
1020 ram 1.5
1021 wlott 1.1
1022     ;;;; inform-type-system-about-class
1023     ;;;
1024 pw 1.26 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1025 wlott 1.1 ;;; which PCL uses to *try* and tell the type system about class definitions.
1026     ;;; In a more fully integrated implementation of CLOS, the type system would
1027     ;;; know about class objects and class names in a more fundamental way and
1028     ;;; the mechanism used to inform the type system about new classes would be
1029     ;;; different.
1030     ;;;
1031     (defmethod inform-type-system-about-class ((class std-class) name)
1032 pw 1.26 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1033     ;; compiler warnings. Not otherwise needed in this implementation.
1034 ram 1.4 (inform-type-system-about-std-class name))
1035 pw 1.26
1036     (defmethod inform-type-system-about-class
1037     ((class funcallable-standard-class) name)
1038     (declare (ignore name))
1039     ;; Avoid load-time warning of changing metaclass.
1040     )
1041    
1042 wlott 1.1
1043    
1044     (defmethod compatible-meta-class-change-p (class proto-new-class)
1045     (eq (class-of class) (class-of proto-new-class)))
1046    
1047 ram 1.4 (defmethod validate-superclass ((class class) (new-super class))
1048     (or (eq new-super *the-class-t*)
1049     (eq (class-of class) (class-of new-super))))
1050 wlott 1.1
1051 dtc 1.16 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1052     (let ((new-super-meta-class (class-of new-super)))
1053     (or (eq new-super-meta-class *the-class-std-class*)
1054     (eq (class-of class) new-super-meta-class))))
1055 ram 1.4
1056 wlott 1.1
1057     ;;;
1058     ;;;
1059     ;;;
1060     (defun force-cache-flushes (class)
1061     (let* ((owrapper (class-wrapper class))
1062     (state (wrapper-state owrapper)))
1063     ;;
1064     ;; We only need to do something if the state is still T. If the
1065     ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
1066     ;; will already be doing what we want. In particular, we must be
1067     ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
1068     ;; means do what FLUSH does and then some.
1069     ;;
1070 pmai 1.32 (when (eq state t)
1071 ram 1.6 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1072     class)))
1073 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1074     (wrapper-instance-slots-layout owrapper))
1075     (setf (wrapper-class-slots nwrapper)
1076     (wrapper-class-slots owrapper))
1077 ram 1.6 (without-interrupts
1078 pw 1.9 (update-lisp-class-layout class nwrapper)
1079 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1080 pmai 1.32 (invalidate-wrapper owrapper :flush nwrapper))))))
1081 wlott 1.1
1082     (defun flush-cache-trap (owrapper nwrapper instance)
1083     (declare (ignore owrapper))
1084     (set-wrapper instance nwrapper))
1085    
1086    
1087    
1088     ;;;
1089     ;;; make-instances-obsolete can be called by user code. It will cause the
1090     ;;; next access to the instance (as defined in 88-002R) to trap through the
1091     ;;; update-instance-for-redefined-class mechanism.
1092     ;;;
1093     (defmethod make-instances-obsolete ((class std-class))
1094 ram 1.6 (let* ((owrapper (class-wrapper class))
1095     (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1096     class)))
1097 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1098     (wrapper-instance-slots-layout owrapper))
1099     (setf (wrapper-class-slots nwrapper)
1100     (wrapper-class-slots owrapper))
1101 ram 1.6 (without-interrupts
1102 pw 1.9 (update-lisp-class-layout class nwrapper)
1103 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1104 pmai 1.32 (invalidate-wrapper owrapper :obsolete nwrapper)
1105 ram 1.6 class)))
1106 wlott 1.1
1107     (defmethod make-instances-obsolete ((class symbol))
1108     (make-instances-obsolete (find-class class)))
1109    
1110    
1111     ;;;
1112     ;;; obsolete-instance-trap is the internal trap that is called when we see
1113     ;;; an obsolete instance. The times when it is called are:
1114     ;;; - when the instance is involved in method lookup
1115     ;;; - when attempting to access a slot of an instance
1116     ;;;
1117     ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1118     ;;; access macros.
1119     ;;;
1120     ;;; Of course these times when it is called are an internal implementation
1121     ;;; detail of PCL and are not part of the documented description of when the
1122     ;;; obsolete instance update happens. The documented description is as it
1123     ;;; appears in 88-002R.
1124     ;;;
1125     ;;; This has to return the new wrapper, so it counts on all the methods on
1126     ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1127     ;;; a little internal error checking to make sure that the traps are only
1128     ;;; happening when they should, and that the trap methods are computing
1129     ;;; apropriate new wrappers.
1130     ;;;
1131 pw 1.9
1132     ;;; obsolete-instance-trap might be called on structure instances
1133     ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1134     ;;; will not be able to fix the old instance, so it must signal an
1135     ;;; error. The hard part of this is that the error system and debugger
1136     ;;; might cause obsolete-instance-trap to be called again, so in that
1137     ;;; case, we have to return some reasonable wrapper, instead.
1138    
1139     (defvar *in-obsolete-instance-trap* nil)
1140     (defvar *the-wrapper-of-structure-object*
1141     (class-wrapper (find-class 'structure-object)))
1142    
1143     (define-condition obsolete-structure (error)
1144     ((datum :reader obsolete-structure-datum :initarg :datum))
1145     (:report
1146     (lambda (condition stream)
1147     ;; Don't try to print the structure, since it probably
1148     ;; won't work.
1149     (format stream "Obsolete structure error in ~S:~@
1150     For a structure of type: ~S"
1151     (conditions::condition-function-name condition)
1152     (type-of (obsolete-structure-datum condition))))))
1153    
1154     (defun obsolete-instance-trap (owrapper nwrapper instance)
1155 pw 1.25 (if (not (pcl-instance-p instance))
1156 pw 1.9 (if *in-obsolete-instance-trap*
1157     *the-wrapper-of-structure-object*
1158     (let ((*in-obsolete-instance-trap* t))
1159     (error 'obsolete-structure :datum instance)))
1160     (let* ((class (wrapper-class* nwrapper))
1161     (copy (allocate-instance class)) ;??? allocate-instance ???
1162     (olayout (wrapper-instance-slots-layout owrapper))
1163     (nlayout (wrapper-instance-slots-layout nwrapper))
1164     (oslots (get-slots instance))
1165     (nslots (get-slots copy))
1166     (oclass-slots (wrapper-class-slots owrapper))
1167     (added ())
1168     (discarded ())
1169     (plist ()))
1170     ;; local --> local transfer
1171     ;; local --> shared discard
1172     ;; local --> -- discard
1173     ;; shared --> local transfer
1174     ;; shared --> shared discard
1175     ;; shared --> -- discard
1176     ;; -- --> local add
1177     ;; -- --> shared --
1178     ;;
1179     ;; Go through all the old local slots.
1180 pmai 1.32 ;;
1181     (loop for name in olayout and opos from 0
1182     as npos = (posq name nlayout)
1183     if npos do
1184     (setf (instance-ref nslots npos)
1185     (instance-ref oslots opos))
1186     else do
1187     (push name discarded)
1188     (unless (eq (instance-ref oslots opos) *slot-unbound*)
1189     (setf (getf plist name)
1190     (instance-ref oslots opos))))
1191 pw 1.9 ;;
1192     ;; Go through all the old shared slots.
1193     ;;
1194 pmai 1.32 (loop for (name . val) in oclass-slots
1195     for npos = (posq name nlayout)
1196     if npos do
1197     (setf (instance-ref nslots npos) val)
1198     else do
1199     (push name discarded)
1200     (unless (eq val *slot-unbound*)
1201     (setf (getf plist name) val)))
1202 pw 1.9 ;;
1203     ;; Go through all the new local slots to compute the added slots.
1204     ;;
1205     (dolist (nlocal nlayout)
1206     (unless (or (memq nlocal olayout)
1207     (assq nlocal oclass-slots))
1208     (push nlocal added)))
1209 wlott 1.1
1210 pw 1.9 (swap-wrappers-and-slots instance copy)
1211 wlott 1.1
1212 pw 1.9 (update-instance-for-redefined-class instance
1213     added
1214     discarded
1215     plist)
1216     nwrapper)))
1217 wlott 1.1
1218    
1219     ;;;
1220     ;;;
1221     ;;;
1222 ram 1.6 (defmacro copy-instance-internal (instance)
1223 pw 1.23 `(progn
1224 ram 1.6 (let* ((class (class-of instance))
1225     (copy (allocate-instance class)))
1226     (if (std-instance-p ,instance)
1227     (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
1228     (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
1229 pw 1.23 copy)))
1230 wlott 1.1
1231 pmai 1.29 (defun change-class-internal (instance new-class initargs)
1232 ram 1.6 (let* ((old-class (class-of instance))
1233 pw 1.9 (copy (allocate-instance new-class))
1234     (new-wrapper (get-wrapper copy))
1235 ram 1.6 (old-wrapper (class-wrapper old-class))
1236     (old-layout (wrapper-instance-slots-layout old-wrapper))
1237     (new-layout (wrapper-instance-slots-layout new-wrapper))
1238     (old-slots (get-slots instance))
1239 pw 1.9 (new-slots (get-slots copy))
1240 ram 1.6 (old-class-slots (wrapper-class-slots old-wrapper)))
1241    
1242 wlott 1.1 ;;
1243     ;; "The values of local slots specified by both the class Cto and
1244     ;; Cfrom are retained. If such a local slot was unbound, it remains
1245     ;; unbound."
1246 pmai 1.32 ;;
1247     (loop for new-slot in new-layout and new-position from 0
1248     for old-position = (posq new-slot old-layout)
1249     when old-position do
1250     (setf (instance-ref new-slots new-position)
1251     (instance-ref old-slots old-position)))
1252 wlott 1.1 ;;
1253     ;; "The values of slots specified as shared in the class Cfrom and
1254     ;; as local in the class Cto are retained."
1255     ;;
1256 pmai 1.32 (loop for (name . val) in old-class-slots
1257     for new-position = (posq name new-layout)
1258     when new-position do
1259     (setf (instance-ref new-slots new-position) val))
1260 wlott 1.1
1261     ;; Make the copy point to the old instance's storage, and make the
1262     ;; old instance point to the new storage.
1263 pw 1.9 (swap-wrappers-and-slots instance copy)
1264 wlott 1.1
1265 pmai 1.29 (apply #'update-instance-for-different-class copy instance initargs)
1266 wlott 1.1 instance))
1267    
1268     (defmethod change-class ((instance standard-object)
1269 pmai 1.29 (new-class standard-class)
1270     &rest initargs)
1271     (change-class-internal instance new-class initargs))
1272 wlott 1.1
1273 dtc 1.15 (defmethod change-class ((instance funcallable-standard-object)
1274 pmai 1.29 (new-class funcallable-standard-class)
1275     &rest initargs)
1276     (change-class-internal instance new-class initargs))
1277 dtc 1.17
1278     (defmethod change-class ((instance standard-object)
1279 pmai 1.29 (new-class funcallable-standard-class)
1280     &rest initargs)
1281     (declare (ignore initargs))
1282 dtc 1.17 (error "Can't change the class of ~S to ~S~@
1283     because it isn't already an instance with metaclass ~S."
1284     instance new-class 'standard-class))
1285    
1286     (defmethod change-class ((instance funcallable-standard-object)
1287 pmai 1.29 (new-class standard-class)
1288     &rest initargs)
1289     (declare (ignore initargs))
1290 dtc 1.17 (error "Can't change the class of ~S to ~S~@
1291     because it isn't already an instance with metaclass ~S."
1292     instance new-class 'funcallable-standard-class))
1293 wlott 1.1
1294 pmai 1.29 (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1295     (apply #'change-class instance (find-class new-class-name) initargs))
1296 wlott 1.1
1297    
1298    
1299     ;;;
1300     ;;; The metaclass BUILT-IN-CLASS
1301     ;;;
1302     ;;; This metaclass is something of a weird creature. By this point, all
1303     ;;; instances of it which will exist have been created, and no instance
1304     ;;; is ever created by calling MAKE-INSTANCE.
1305     ;;;
1306     ;;; But, there are other parts of the protcol we must follow and those
1307     ;;; definitions appear here.
1308     ;;;
1309     (defmethod shared-initialize :before
1310     ((class built-in-class) slot-names &rest initargs)
1311 ram 1.5 (declare (ignore slot-names initargs))
1312 wlott 1.1 (error "Attempt to initialize or reinitialize a built in class."))
1313    
1314 ram 1.6 (defmethod class-direct-slots ((class built-in-class)) ())
1315     (defmethod class-slots ((class built-in-class)) ())
1316     (defmethod class-direct-default-initargs ((class built-in-class)) ())
1317     (defmethod class-default-initargs ((class built-in-class)) ())
1318    
1319 ram 1.4 (defmethod validate-superclass ((c class) (s built-in-class))
1320 pw 1.25 (or (eq s *the-class-t*) (eq s *the-class-stream*)))
1321 wlott 1.1
1322 ram 1.4
1323 wlott 1.1
1324     ;;;
1325     ;;;
1326     ;;;
1327    
1328 ram 1.4 (defmethod validate-superclass ((c slot-class)
1329 dtc 1.16 (f forward-referenced-class))
1330 pmai 1.32 t)
1331 wlott 1.1
1332    
1333     ;;;
1334     ;;;
1335     ;;;
1336    
1337     (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1338     (pushnew dependent (plist-value metaobject 'dependents)))
1339    
1340     (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1341     (setf (plist-value metaobject 'dependents)
1342     (delete dependent (plist-value metaobject 'dependents))))
1343    
1344     (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1345     (dolist (dependent (plist-value metaobject 'dependents))
1346 ram 1.2 (funcall function dependent)))
1347 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5