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

  ViewVC Help
Powered by ViewVC 1.1.5