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

  ViewVC Help
Powered by ViewVC 1.1.5