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

  ViewVC Help
Powered by ViewVC 1.1.5