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

  ViewVC Help
Powered by ViewVC 1.1.5