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

  ViewVC Help
Powered by ViewVC 1.1.5