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

  ViewVC Help
Powered by ViewVC 1.1.5