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

  ViewVC Help
Powered by ViewVC 1.1.5