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

  ViewVC Help
Powered by ViewVC 1.1.5