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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5