/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Contents of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5