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

  ViewVC Help
Powered by ViewVC 1.1.5