1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 (defmethod slot-accessor-function ((slotd effective-slot-definition
) type
)
27 (let ((info (the slot-info
(slot-definition-info slotd
))))
29 (reader (slot-info-reader info
))
30 (writer (slot-info-writer info
))
31 (boundp (slot-info-boundp info
)))))
33 (defmethod (setf slot-accessor-function
) (function
34 (slotd effective-slot-definition
)
36 (let ((info (the slot-info
(slot-definition-info slotd
))))
38 (reader (setf (slot-info-reader info
) function
))
39 (writer (setf (slot-info-writer info
) function
))
40 (boundp (setf (slot-info-boundp info
) function
)))))
42 (defconstant +slotd-reader-function-std-p
+ 1)
43 (defconstant +slotd-writer-function-std-p
+ 2)
44 (defconstant +slotd-boundp-function-std-p
+ 4)
45 (defconstant +slotd-all-function-std-p
+ 7)
47 (defmethod slot-accessor-std-p ((slotd effective-slot-definition
) type
)
48 (let ((flags (slot-value slotd
'accessor-flags
)))
49 (declare (type fixnum flags
))
51 (eql +slotd-all-function-std-p
+ flags
)
52 (logtest flags
(ecase type
53 (reader +slotd-reader-function-std-p
+)
54 (writer +slotd-writer-function-std-p
+)
55 (boundp +slotd-boundp-function-std-p
+))))))
57 (defmethod (setf slot-accessor-std-p
) (value
58 (slotd effective-slot-definition
)
60 (let ((mask (ecase type
61 (reader +slotd-reader-function-std-p
+)
62 (writer +slotd-writer-function-std-p
+)
63 (boundp +slotd-boundp-function-std-p
+)))
64 (flags (slot-value slotd
'accessor-flags
)))
65 (declare (type fixnum mask flags
))
66 (setf (slot-value slotd
'accessor-flags
)
67 (logior (logandc2 flags mask
) (if value mask
0))))
70 (defmethod initialize-internal-slot-functions
71 ((slotd effective-slot-definition
))
72 (let* ((name (slot-value slotd
'name
)) ; flushable? (is it ever unbound?)
73 (class (slot-value slotd
'%class
)))
74 (declare (ignore name
))
75 (dolist (type '(reader writer boundp
))
76 (let* ((gf-name (ecase type
77 (reader 'slot-value-using-class
)
78 (writer '(setf slot-value-using-class
))
79 (boundp 'slot-boundp-using-class
)))
80 (gf (gdefinition gf-name
)))
81 ;; KLUDGE: this logic is cut'n'pasted from
82 ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
83 ;; only called later, because it does things that can't be
84 ;; computed this early in class finalization; however, we need
85 ;; this bit as early as possible. -- CSR, 2009-11-05
86 (setf (slot-accessor-std-p slotd type
)
87 (let* ((types1 `((eql ,class
) (class-eq ,class
) (eql ,slotd
)))
88 (types (if (eq type
'writer
) `(t ,@types1
) types1
))
89 (methods (compute-applicable-methods-using-types gf types
)))
90 (null (cdr methods
))))
91 (setf (slot-accessor-function slotd type
)
93 (declare (dynamic-extent args
))
94 ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
95 ;; work here (see KLUDGE comment above).
96 (let ((fun (compute-slot-accessor-info slotd type gf
)))
97 (apply fun args
))))))))
99 (defmethod finalize-internal-slot-functions ((slotd effective-slot-definition
))
100 (dolist (type '(reader writer boundp
))
101 (let* ((gf-name (ecase type
102 (reader 'slot-value-using-class
)
103 (writer '(setf slot-value-using-class
))
104 (boundp 'slot-boundp-using-class
)))
105 (gf (gdefinition gf-name
)))
106 (compute-slot-accessor-info slotd type gf
))))
108 ;;; CMUCL (Gerd PCL 2003-04-25) comment:
110 ;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
111 ;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
112 ;;; writing/testing effective slot SLOTD.
114 ;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
115 ;;; GF. Store the effective method in the effective slot definition
116 ;;; object itself; these GFs have special dispatch functions calling
117 ;;; effective methods directly retrieved from effective slot
118 ;;; definition objects, as an optimization.
120 ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
122 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition
)
124 (let* ((name (slot-value slotd
'name
)) ; flushable?
125 (class (slot-value slotd
'%class
)))
126 (declare (ignore name
))
127 (multiple-value-bind (function std-p
)
128 (if (eq **boot-state
** 'complete
)
129 (get-accessor-method-function gf type class slotd
)
130 (get-optimized-std-accessor-method-function class slotd type
))
131 (setf (slot-accessor-std-p slotd type
) std-p
)
132 (setf (slot-accessor-function slotd type
) function
))))
134 (defmethod slot-definition-allocation ((slotd structure-slot-definition
))
137 ;;;; various class accessors that are a little more complicated than can be
138 ;;;; done with automatically generated reader methods
140 (defmethod class-prototype :before
(class)
141 (unless (class-finalized-p class
)
142 (error "~@<~S is not finalized.~:@>" class
)))
144 ;;; KLUDGE: For some reason factoring the common body into a function
145 ;;; breaks PCL bootstrapping, so just generate it with a macrolet for
147 (macrolet ((def (class)
148 `(defmethod class-prototype ((class ,class
))
149 (declare (notinline allocate-instance
))
150 (with-slots (prototype) class
152 (setf prototype
(allocate-instance class
)))))))
154 (def condition-class
)
155 (def structure-class
))
157 (defmethod class-direct-default-initargs ((class slot-class
))
158 (plist-value class
'direct-default-initargs
))
160 (defmethod class-default-initargs ((class slot-class
))
161 (plist-value class
'default-initargs
))
163 (defmethod class-slot-cells ((class std-class
))
164 (plist-value class
'class-slot-cells
))
165 (defmethod (setf class-slot-cells
) (new-value (class std-class
))
166 (setf (plist-value class
'class-slot-cells
) new-value
))
168 ;;;; class accessors that are even a little bit more complicated than those
169 ;;;; above. These have a protocol for updating them, we must implement that
172 ;;; Maintaining the direct subclasses backpointers. The update methods are
173 ;;; here, the values are read by an automatically generated reader method.
174 (defmethod add-direct-subclass ((class class
) (subclass class
))
175 (with-slots (direct-subclasses) class
176 (pushnew subclass direct-subclasses
:test
#'eq
)
178 (defmethod remove-direct-subclass ((class class
) (subclass class
))
179 (with-slots (direct-subclasses) class
180 (setq direct-subclasses
(remove subclass direct-subclasses
))
183 ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
185 ;;; There are four generic functions involved, each has one method. All of
186 ;;; these are specified methods and appear in their specified place in the
189 ;;; ADD-DIRECT-METHOD
190 ;;; REMOVE-DIRECT-METHOD
191 ;;; SPECIALIZER-DIRECT-METHODS
192 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
194 ;;; In each case, we maintain one value which is a cons. The car is the list
195 ;;; of methods. The cdr is a list of the generic functions. The cdr is always
198 ;;; This needs to be used recursively, in case a non-trivial user
199 ;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
200 ;;; function using the same lock.
201 (defvar *specializer-lock
* (sb-thread:make-mutex
:name
"Specializer lock"))
203 (defmethod add-direct-method :around
((specializer specializer
) method
)
204 ;; All the actions done under this lock are done in an order
205 ;; that is safe to unwind at any point.
206 (sb-thread::with-recursive-system-lock
(*specializer-lock
*)
209 (defmethod remove-direct-method :around
((specializer specializer
) method
)
210 ;; All the actions done under this lock are done in an order
211 ;; that is safe to unwind at any point.
212 (sb-thread::with-recursive-system-lock
(*specializer-lock
*)
215 (defmethod add-direct-method ((specializer specializer
) (method method
))
216 (let ((cell (specializer-method-holder specializer
)))
217 ;; We need to first smash the CDR, because a parallel read may
218 ;; be in progress, and because if an interrupt catches us we
219 ;; need to have a consistent state.
221 (car cell
) (adjoin method
(car cell
) :test
#'eq
)))
224 (defmethod remove-direct-method ((specializer specializer
) (method method
))
225 (let ((cell (specializer-method-holder specializer
)))
226 ;; We need to first smash the CDR, because a parallel read may
227 ;; be in progress, and because if an interrupt catches us we
228 ;; need to have a consistent state.
230 (car cell
) (remove method
(car cell
))))
233 (defmethod specializer-direct-methods ((specializer specializer
))
234 (car (specializer-method-holder specializer nil
)))
236 (defmethod specializer-direct-generic-functions ((specializer specializer
))
237 (let ((cell (specializer-method-holder specializer nil
)))
238 ;; If an ADD/REMOVE-METHOD is in progress, no matter: either
239 ;; we behave as if we got just first or just after -- it's just
240 ;; for update that we need to lock.
244 (sb-thread:with-mutex
(*specializer-lock
*)
246 (dolist (m (car cell
) (nreverse collect
))
247 ;; the old PCL code used COLLECTING-ONCE which used
248 ;; #'EQ to check for newness
249 (pushnew (method-generic-function m
) collect
252 (defmethod specializer-method-holder ((self specializer
) &optional create
)
253 ;; CREATE can be ignored, because instances of SPECIALIZER
254 ;; other than CLASS-EQ-SPECIALIZER have their DIRECT-METHODS slot
255 ;; preinitialized with (NIL . NIL).
256 (declare (ignore create
))
257 (slot-value self
'direct-methods
))
259 ;; Same as for CLASS but the only ancestor it shares is SPECIALIZER.
260 ;; If this were defined on SPECIALIZER-WITH-OBJECT then it would
261 ;; apply as well to CLASS-EQ specializers which we don't want.
262 (defmethod specializer-method-holder ((self eql-specializer
) &optional create
)
263 (declare (ignore create
))
264 (slot-value self
'direct-methods
))
266 ;;; This hash table is used to store the direct methods and direct generic
267 ;;; functions of CLASS-EQ specializers.
268 ;;; This is needed because CLASS-EQ specializers are not interned: two different
269 ;;; specializers could refer to the identical CLASS. But semantically you don't
270 ;;; want to collect the direct methods separately, you want them all together.
271 ;;; So a logical place to do that would be in the CLASS. We could add another
272 ;;; slot to CLASS holding the CLASS-EQ-DIRECT-METHODS. I guess the idea though
273 ;;; is to be able to define other kinds of specializers that hold an object
274 ;;; where you don't have the ability to add a slot to that object.
275 ;;; So that's fine, you look up the object in this table, and the approach
276 ;;; generalizes by defining other tables similarly, but has the same problem
277 ;;; of garbage retention as did EQL specializers.
278 ;;; I suspect CLASS-EQ specializers aren't used enough to worry about.
280 ;;; This table is shared between threads, so needs to be synchronized.
281 ;;; (though insertions are only performed when holding the specializer-lock,
282 ;;; so the preceding claim is probably overly paranoid.)
283 (defvar *class-eq-specializer-methods
* (make-hash-table :test
'eq
:synchronized t
))
285 (defmethod specializer-method-table ((specializer class-eq-specializer
))
286 *class-eq-specializer-methods
*)
288 (defmethod specializer-method-holder ((self specializer-with-object
)
289 &optional
(create t
))
290 (let ((table (specializer-method-table self
))
291 (object (specializer-object self
)))
293 (sb-impl::puthash-if-absent object table
(lambda () (cons nil nil
)))
294 (gethash object table
))))
296 (defun map-specializers (function)
297 (map-all-classes (lambda (class)
298 (funcall function
(class-eq-specializer class
))
299 (funcall function class
)))
300 (maphash (lambda (object specl
)
301 (declare (ignore object
))
302 (funcall function specl
))
303 *eql-specializer-table
*)
306 (defun map-all-generic-functions (function)
307 (let ((all-generic-functions (make-hash-table :test
'eq
)))
308 (map-specializers (lambda (specl)
309 (dolist (gf (specializer-direct-generic-functions
311 (unless (gethash gf all-generic-functions
)
312 (setf (gethash gf all-generic-functions
) t
)
313 (funcall function gf
))))))
316 (defmethod shared-initialize :after
((specl class-eq-specializer
)
319 (declare (ignore slot-names
))
320 (setf (slot-value specl
'%type
) `(class-eq ,(specializer-class specl
))))
322 (defmethod shared-initialize :after
((specl eql-specializer
) slot-names
&key
)
323 (declare (ignore slot-names
))
324 (setf (slot-value specl
'%type
)
325 `(eql ,(specializer-object specl
))))
327 (defun real-load-defclass (name metaclass-name supers slots other
328 readers writers slot-names source-location
&optional safe-p
)
329 (with-single-package-locked-error (:symbol name
"defining ~S as a class")
330 (%compiler-defclass name readers writers slot-names
)
331 (let ((res (apply #'ensure-class name
:metaclass metaclass-name
332 :direct-superclasses supers
334 :definition-source source-location
339 (setf (gdefinition 'load-defclass
) #'real-load-defclass
)
341 (defun ensure-class (name &rest args
)
343 (apply #'ensure-class-using-class
344 (let ((class (find-class name nil
)))
345 (when (and class
(eq name
(class-name class
)))
346 ;; NAME is the proper name of CLASS, so redefine it
350 (defun parse-ensure-class-args (class name args
)
351 (let ((metaclass *the-class-standard-class
*)
353 (reversed-plist '()))
354 (labels ((find-class* (which class-or-name
)
356 ((classp class-or-name
)
358 ((eq class-or-name class
)
359 (error "~@<Class ~A specified as its own ~
361 class-or-name which
))
364 ((and class-or-name
(legal-class-name-p class-or-name
))
366 ((eq class-or-name name
)
367 (error "~@<Class named ~
368 ~/sb-impl::print-symbol-with-prefix/ ~
369 specified as its own ~(~A~)class.~@:>"
370 class-or-name which
))
371 ((find-class class-or-name
(eq which
:meta
)))
373 class-or-name
:metaclass
'forward-referenced-class
))))
375 (error "~@<Not a class or a legal ~(~A~)class name: ~
377 which class-or-name
))))
378 (find-superclass (class-or-name)
379 (find-class* :super class-or-name
)))
380 (doplist (key value
) args
384 (setf metaclass
(find-class* :meta value
)
386 (:direct-superclasses
387 (let ((superclasses (mapcar #'find-superclass value
)))
388 (setf reversed-plist
(list* superclasses key reversed-plist
))))
390 (setf reversed-plist
(list* value key reversed-plist
)))))
391 (values metaclass
(nreverse reversed-plist
)))))
393 (defun call-with-ensure-class-context (class name args thunk
)
394 (let ((class (with-world-lock ()
395 (multiple-value-bind (metaclass initargs
)
396 (parse-ensure-class-args class name args
)
397 (let ((class (funcall thunk class name metaclass initargs
)))
398 (without-package-locks
399 (setf (find-class name
) class
)))))))
402 (defmethod ensure-class-using-class ((class null
) name
&rest args
&key
)
403 (call-with-ensure-class-context
404 class name args
(lambda (class name metaclass initargs
)
405 (declare (ignore class
))
406 (apply #'make-instance metaclass
:name name initargs
))))
408 (defmethod ensure-class-using-class ((class pcl-class
) name
&rest args
&key
)
409 (call-with-ensure-class-context
410 class name args
(lambda (class name metaclass initargs
)
411 (aver (eq name
(class-name class
)))
412 (unless (eq (class-of class
) metaclass
)
413 (apply #'change-class class metaclass initargs
))
414 (apply #'reinitialize-instance class initargs
)
417 ;;; This is used to call initfunctions of :allocation :class slots.
418 (defun call-initfun (fun slotd safe
)
419 (declare (function fun
))
420 (let ((value (funcall fun
)))
422 (let ((type (slot-definition-type slotd
)))
423 (unless (or (eq t type
)
425 (error 'type-error
:expected-type type
:datum value
))))
428 (defmethod shared-initialize :after
429 ((class std-class
) slot-names
&key
430 (direct-superclasses nil direct-superclasses-p
)
431 (direct-slots nil direct-slots-p
)
432 (direct-default-initargs nil direct-default-initargs-p
))
433 (cond (direct-superclasses-p
434 (setq direct-superclasses
435 (or direct-superclasses
436 (list (if (funcallable-standard-class-p class
)
437 *the-class-funcallable-standard-object
*
438 *the-class-standard-object
*))))
439 (dolist (superclass direct-superclasses
)
440 (unless (validate-superclass class superclass
)
441 (invalid-superclass class superclass
)))
442 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
444 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
447 (setf (slot-value class
'direct-slots
)
448 (mapcar (lambda (pl) (make-direct-slotd class pl
))
450 (slot-value class
'direct-slots
)))
451 (if direct-default-initargs-p
452 (setf (plist-value class
'direct-default-initargs
)
453 direct-default-initargs
)
454 (setq direct-default-initargs
455 (plist-value class
'direct-default-initargs
)))
456 (setf (plist-value class
'class-slot-cells
)
457 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
458 (safe (safe-p class
))
460 (dolist (dslotd direct-slots
)
461 (when (eq :class
(slot-definition-allocation dslotd
))
463 (let* ((name (slot-definition-name dslotd
))
464 (old (assoc name old-class-slot-cells
)))
467 (member name slot-names
:test
#'eq
))
468 (let* ((initfunction (slot-definition-initfunction dslotd
))
471 (call-initfun initfunction dslotd safe
)
473 (push (cons name value
) collect
))
474 (push old collect
)))))
476 (add-direct-subclasses class direct-superclasses
)
477 (if (class-finalized-p class
)
478 ;; required by AMOP, "Reinitialization of Class Metaobjects"
479 (finalize-inheritance class
)
480 (update-class class nil
))
481 (add-slot-accessors class direct-slots
)
482 (make-preliminary-layout class
))
484 (define-condition invalid-superclass
(reference-condition error
)
485 ((class :initarg
:class
:reader invalid-superclass-class
)
486 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
489 (let ((class (invalid-superclass-class c
))
490 (superclass (invalid-superclass-superclass c
)))
492 "~@<The class ~S was specified as a superclass of the ~
493 class ~S, but the metaclasses ~S and ~S are ~
494 incompatible.~@[ Define a method for ~S to avoid this ~
496 superclass class
(class-of superclass
) (class-of class
)
497 (and (typep superclass
'standard-class
)
498 'validate-superclass
))))))
500 (defmethod invalid-superclass ((class class
) (superclass class
))
501 (error 'invalid-superclass
:class class
:superclass superclass
502 :references
(list* '(:amop
:generic-function validate-superclass
)
503 (and (typep superclass
'built-in-class
)
504 (list '(:ansi-cl
:system-class built-in-class
)
505 '(:ansi-cl
:section
(4 3 7)))))))
507 (defmethod shared-initialize :after
((class forward-referenced-class
)
508 slot-names
&key
&allow-other-keys
)
509 (declare (ignore slot-names
))
510 (make-preliminary-layout class
))
512 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
514 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
515 ;;; make it known to the type system.
516 (defun make-preliminary-layout (class)
517 (flet ((compute-preliminary-cpl (root)
518 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
519 (compute-class-precedence-list root
))))
521 (without-package-locks
522 (unless (class-finalized-p class
)
523 (let ((name (class-name class
))) ; flushable?
524 (declare (ignore name
))
525 ;; KLUDGE: This is fairly horrible. We need to make a
526 ;; full-fledged CLASSOID here, not just tell the compiler that
527 ;; some class is forthcoming, because there are legitimate
528 ;; questions one can ask of the type system, implemented in
529 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
530 (let ((layout (make-wrapper 0 class
)))
531 (setf (slot-value class
'wrapper
) layout
)
532 (let ((cpl (compute-preliminary-cpl class
)))
533 (setf (layout-inherits layout
)
534 (order-layout-inherits
535 (map 'simple-vector
#'class-wrapper
536 (reverse (rest cpl
))))))
537 (register-layout layout
:invalidate t
))))
538 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
541 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
542 (declare (ignore slot-names name
))
543 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
544 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
545 (setf (slot-value class
'%type
) `(class ,class
))
546 (setf (slot-value class
'class-eq-specializer
)
547 (make-instance 'class-eq-specializer
:class class
)))
549 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
550 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
551 (remove-direct-subclass old-super class
))
552 (remove-slot-accessors class
(class-direct-slots class
)))
554 (defmethod reinitialize-instance :after
((class slot-class
)
557 (map-dependents class
559 (apply #'update-dependent class dependent initargs
))))
561 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
562 (let* ((name (class-name class
))
563 (classoid (find-classoid name
))
564 (slots (condition-classoid-slots classoid
))
565 (source (sb-kernel::layout-source-location
(classoid-layout classoid
))))
566 ;; to balance the REMOVE-SLOT-ACCESSORS call in
567 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
568 (flet ((add-source-location (method)
570 (setf (slot-value method
'source
) source
))))
572 (let ((slot-name (condition-slot-name slot
)))
573 (dolist (reader (condition-slot-readers slot
))
574 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
575 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
577 (sb-kernel::install-condition-slot-reader reader name slot-name
)))
578 (dolist (writer (condition-slot-writers slot
))
580 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))))
582 (defmethod shared-initialize :after
((class condition-class
) slot-names
583 &key direct-slots direct-superclasses
)
584 (declare (ignore slot-names
))
585 (let ((classoid (find-classoid (slot-value class
'name
))))
587 %class-precedence-list cpl-available-p finalized-p
588 prototype
(direct-supers direct-superclasses
)
591 (setf (slot-value class
'direct-slots
)
592 (mapcar (lambda (pl) (make-direct-slotd class pl
))
595 (classoid-pcl-class classoid
) class
596 direct-supers direct-superclasses
597 wrapper
(classoid-layout classoid
)
598 %class-precedence-list
(compute-class-precedence-list class
)
600 (getf plist
'direct-default-initargs
)
601 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
602 (add-direct-subclasses class direct-superclasses
)
603 (let ((slots (compute-slots class
)))
604 (setf (slot-value class
'slots
) slots
)
605 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
606 ;; Comment from Gerd's PCL, 2003-05-15:
608 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
609 ;; override condition accessors with generic functions. We do this
612 ;; ??? What does the above comment mean and why is it a good idea?
613 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
614 ;; comment) loses slot information in its condition classes:
615 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
616 ;; remove slot accessors but never put them back. I've added a
617 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
618 ;; was meant to happen? -- CSR, 2005-11-18
621 (defmethod direct-slot-definition-class ((class condition-class
)
623 (declare (ignore initargs
))
624 (find-class 'condition-direct-slot-definition
))
626 (defmethod effective-slot-definition-class ((class condition-class
)
628 (declare (ignore initargs
))
629 (find-class 'condition-effective-slot-definition
))
631 (defmethod finalize-inheritance ((class condition-class
))
632 (aver (slot-value class
'finalized-p
))
635 (defmethod compute-effective-slot-definition
636 ((class condition-class
) slot-name dslotds
)
637 (let* ((slotd (call-next-method))
638 (info (slot-definition-info slotd
)))
639 (setf (slot-info-reader info
)
641 (handler-case (condition-reader-function x slot-name
)
642 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
643 ;; is unbound; maybe it should be a CELL-ERROR of some
645 (error () (values (slot-unbound class x slot-name
))))))
646 (setf (slot-info-writer info
)
648 (condition-writer-function x v slot-name
)))
649 (setf (slot-info-boundp info
)
651 (multiple-value-bind (v c
)
652 (ignore-errors (condition-reader-function x slot-name
))
657 (defmethod compute-slots :around
((class condition-class
))
658 (let ((eslotds (call-next-method)))
659 (mapc #'finalize-internal-slot-functions eslotds
)
662 (defmethod shared-initialize :after
663 ((slotd structure-slot-definition
) slot-names
&key
664 (allocation :instance
) allocation-class
)
665 (declare (ignore slot-names allocation-class
))
666 (unless (eq allocation
:instance
)
667 (error "Structure slots must have :INSTANCE allocation.")))
669 (defun make-structure-class-defstruct-form (name direct-slots include
)
670 (let* ((conc-name (format-symbol *package
* "~S structure class " name
))
671 (constructor (format-symbol *package
* "~Aconstructor" conc-name
))
672 (included-name (class-name include
))
675 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
680 (dolist (slotd (reverse direct-slots
))
681 (let* ((slot-name (slot-definition-name slotd
))
682 (initform (slot-definition-initform slotd
))
683 (type (slot-definition-type slotd
))
684 (desc `(,slot-name
,initform
:type
,type
)))
685 (push `(slot-accessor ,name
,slot-name reader
)
687 (push `(slot-accessor ,name
,slot-name writer
)
689 (if (member slot-name included-slots
:test
#'eq
)
690 (push desc old-slots
)
691 (push desc new-slots
))))
692 (let* ((defstruct `(defstruct (,name
694 `((:include
,included-name
696 (:constructor
,constructor
())
698 (:conc-name
,conc-name
)
702 (mapcar (lambda (slotd reader-name
)
704 (slot-definition-defstruct-accessor-symbol
706 `(defun ,reader-name
(obj)
707 (declare (type ,name obj
))
709 direct-slots reader-names
))
711 (mapcar (lambda (slotd writer-name
)
713 (slot-definition-defstruct-accessor-symbol
715 `(defun ,writer-name
(nv obj
)
716 (declare (type ,name obj
))
717 (setf (,accessor obj
) nv
))))
718 direct-slots writer-names
))
722 ,@readers-init
,@writers-init
724 (values defstruct-form constructor reader-names writer-names
))))
726 ;;; Return a thunk to allocate an instance of CLASS named NAME.
727 ;;; This is broken with regard to the expectation that all semantic
728 ;;; processing is done by the compiler. e.g. after COMPILE-FILE on
729 ;;; a file containing these two toplevel forms:
730 ;;; (eval-when (:compile-toplevel) (defmacro maker () '(list 1)))
731 ;;; (defstruct foo (a (maker)))
732 ;;; then LOADing the resulting fasl in a fresh image will err:
733 ;;; (make-instance 'foo) => "The function MAKER is undefined."
735 ;;; The way to fix that is to ensure that every defstruct has a zero-argument
736 ;;; constructor made by the compiler and stashed in a random symbol.
737 (defun make-defstruct-allocation-function (name class
)
738 (declare (muffle-conditions code-deletion-note
))
739 ;; FIXME: Why don't we go class->layout->info == dd
740 (let ((dd (find-defstruct-description name
)))
743 ;; This used to call COMPILE directly, which is basically pointless,
744 ;; because it certainly does not avoid compiling code at runtime,
745 ;; which seems to have been the goal. We're also compiling:
746 ;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #<STRUCTURE-CLASS THING>))
747 ;; So maybe we can figure out how to bundle two lambdas together?
749 (let* ((dd (layout-info (class-wrapper class
)))
750 (f (%make-structure-instance-allocator dd nil
)))
752 (funcall (setf (slot-value class
'defstruct-constructor
) f
))
753 (error "Can't allocate ~S" class
)))))
754 (funcallable-structure
755 ;; FIXME: you can't dynamically define new funcallable structures
756 ;; that are not GENERIC-FUNCTION subtypes, so why this branch?
757 ;; We should pull this out, fixup PCL bootstrap, and not pretend
758 ;; that this code is more general than it really is.
759 (%make-funcallable-structure-instance-allocator dd nil
)))))
761 (defmethod shared-initialize :after
762 ((class structure-class
) slot-names
&key
763 (direct-superclasses nil direct-superclasses-p
)
764 (direct-slots nil direct-slots-p
)
765 direct-default-initargs
)
766 (declare (ignore slot-names direct-default-initargs
))
767 (if direct-superclasses-p
768 (setf (slot-value class
'direct-superclasses
)
769 (or direct-superclasses
770 (setq direct-superclasses
771 (and (not (eq (slot-value class
'name
) 'structure-object
))
772 (list *the-class-structure-object
*)))))
773 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
774 (let* ((name (slot-value class
'name
))
775 (from-defclass-p (slot-value class
'from-defclass-p
))
776 ;; DEFSTRUCT-P means we should perform the effect of DEFSTRUCT,
777 ;; and not that this structure came from a DEFSTRUCT.
778 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
780 (setf (slot-value class
'direct-slots
)
784 (let* ((slot-name (getf pl
:name
))
786 (format-symbol *package
*
787 "~S structure class ~A"
789 (setq pl
(list* :defstruct-accessor-symbol
791 (make-direct-slotd class pl
))
793 (setq direct-slots
(slot-value class
'direct-slots
)))
795 (let ((include (car (slot-value class
'direct-superclasses
))))
796 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
797 (make-structure-class-defstruct-form name direct-slots include
)
798 (unless (structure-type-p name
) (eval defstruct-form
))
799 (mapc (lambda (dslotd reader-name writer-name
)
800 (let* ((reader (gdefinition reader-name
))
801 (writer (when (fboundp writer-name
)
802 (gdefinition writer-name
))))
803 (setf (slot-value dslotd
'internal-reader-function
)
805 (setf (slot-value dslotd
'internal-writer-function
)
807 direct-slots reader-names writer-names
)
808 (setf (slot-value class
'defstruct-form
) defstruct-form
)
809 (setf (slot-value class
'defstruct-constructor
) constructor
)))
810 ;; FIXME: If we always need a default constructor, then why not just make
811 ;; a "hidden" one at actual-compile-time and store it?
812 ;; And this is very broken with regard to the lexical environment.
813 ;; And why isn't this just DD-DEFAULT-CONSTRUCTOR if there was one?
814 (setf (slot-value class
'defstruct-constructor
)
815 ;; KLUDGE: not class; in fixup.lisp, can't access slots
816 ;; outside methods yet.
817 (make-defstruct-allocation-function name class
)))
818 (add-direct-subclasses class direct-superclasses
)
819 (setf (slot-value class
'%class-precedence-list
)
820 (compute-class-precedence-list class
))
821 (setf (slot-value class
'cpl-available-p
) t
)
822 (let ((slots (compute-slots class
)))
823 (setf (slot-value class
'slots
) slots
)
824 (let* ((lclass (find-classoid (slot-value class
'name
)))
825 (layout (classoid-layout lclass
)))
826 (setf (classoid-pcl-class lclass
) class
)
827 (setf (slot-value class
'wrapper
) layout
)
828 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
829 (setf (slot-value class
'finalized-p
) t
)
830 (add-slot-accessors class direct-slots
)))
832 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
833 (declare (ignore initargs
))
834 (find-class 'structure-direct-slot-definition
))
836 (defmethod finalize-inheritance ((class structure-class
))
837 nil
) ; always finalized
839 (defun add-slot-accessors (class dslotds
)
840 (fix-slot-accessors class dslotds
'add
))
842 (defun remove-slot-accessors (class dslotds
)
843 (fix-slot-accessors class dslotds
'remove
))
845 (defun fix-slot-accessors (class dslotds add
/remove
)
846 (flet ((fix (gfspec name r
/w doc source-location
)
847 (let ((gf (cond ((eq add
/remove
'add
)
848 (or (find-generic-function gfspec nil
)
849 (ensure-generic-function
850 gfspec
:lambda-list
(case r
/w
852 (w '(new-value object
))))))
854 (find-generic-function gfspec nil
)))))
857 (r (if (eq add
/remove
'add
)
858 (add-reader-method class gf name doc source-location
)
859 (remove-reader-method class gf
)))
860 (w (if (eq add
/remove
'add
)
861 (add-writer-method class gf name doc source-location
)
862 (remove-writer-method class gf
))))))))
863 (dolist (dslotd dslotds
)
864 (let ((slot-name (slot-definition-name dslotd
))
865 (slot-doc (%slot-definition-documentation dslotd
))
866 (location (definition-source dslotd
)))
867 (dolist (r (slot-definition-readers dslotd
))
868 (fix r slot-name
'r slot-doc location
))
869 (dolist (w (slot-definition-writers dslotd
))
870 (fix w slot-name
'w slot-doc location
))))))
872 (defun add-direct-subclasses (class supers
)
873 (dolist (super supers
)
874 (unless (memq class
(class-direct-subclasses class
))
875 (add-direct-subclass super class
))))
877 (defmethod finalize-inheritance ((class std-class
))
878 (update-class class t
))
880 (defmethod finalize-inheritance ((class forward-referenced-class
))
881 ;; FIXME: should we not be thinking a bit about what kinds of error
882 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
883 ;; possibly a forward-referenced-class-error, though that's
884 ;; difficult given e.g. class precedence list calculations...
886 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
891 (defun class-has-a-forward-referenced-superclass-p (class)
892 (or (when (forward-referenced-class-p class
)
894 (some #'class-has-a-forward-referenced-superclass-p
895 (class-direct-superclasses class
))))
897 ;;; This is called by :after shared-initialize whenever a class is initialized
898 ;;; or reinitialized. The class may or may not be finalized.
899 (defun update-class (class finalizep
)
900 (labels ((rec (class finalizep
&optional
(seen '()))
901 (when (find class seen
:test
#'eq
)
902 (error "~@<Specified class ~S as a superclass of ~
905 (without-package-locks
907 (when (or finalizep
(class-finalized-p class
))
908 (%update-cpl class
(compute-class-precedence-list class
))
909 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
911 (%update-slots class
(compute-slots class
))
912 (update-gfs-of-class class
)
913 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
914 (update-ctors 'finalize-inheritance
:class class
))
915 (let ((seen (list* class seen
)))
916 (dolist (sub (class-direct-subclasses class
))
917 (rec sub nil seen
)))))))
918 (rec class finalizep
)))
920 (define-condition cpl-protocol-violation
(reference-condition error
)
921 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
922 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
923 (:default-initargs
:references
(list '(:sbcl
:node
"Metaobject Protocol")))
926 (format s
"~@<Protocol violation: the ~S class ~S ~
927 ~:[has~;does not have~] the class ~S in its ~
928 class precedence list: ~S.~@:>"
929 (class-name (class-of (cpl-protocol-violation-class c
)))
930 (cpl-protocol-violation-class c
)
931 (eq (class-of (cpl-protocol-violation-class c
))
932 *the-class-funcallable-standard-class
*)
933 (find-class 'function
)
934 (cpl-protocol-violation-cpl c
)))))
936 (defun class-has-a-cpl-protocol-violation-p (class)
937 (labels ((find-in-superclasses (class classes
)
940 ((eql class
(car classes
)) t
)
941 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
942 (let ((metaclass (class-of class
)))
944 ((eql metaclass
*the-class-standard-class
*)
945 (find-in-superclasses (find-class 'function
) (list class
)))
946 ((eql metaclass
*the-class-funcallable-standard-class
*)
947 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
949 (defun %update-cpl
(class cpl
)
951 (eq (class-of class
) *the-class-standard-class
*)
952 (find *the-class-function
* cpl
))
953 (and (eq (class-of class
) *the-class-funcallable-standard-class
*)
954 (not (and (find (find-class 'function
) cpl
)))))
955 (error 'cpl-protocol-violation
:class class
:cpl cpl
))
956 (cond ((not (class-finalized-p class
))
957 (setf (slot-value class
'%class-precedence-list
) cpl
958 (slot-value class
'cpl-available-p
) t
))
959 ((not (and (equal (class-precedence-list class
) cpl
)
961 (when (position :class
(class-direct-slots c
)
962 :key
#'slot-definition-allocation
)
965 ;; comment from the old CMU CL sources:
966 ;; Need to have the cpl setup before %update-lisp-class-layout
967 ;; is called on CMU CL.
968 (setf (slot-value class
'%class-precedence-list
) cpl
969 (slot-value class
'cpl-available-p
) t
)
970 (%force-cache-flushes class
)))
971 (update-class-can-precede-p cpl
))
973 (defun update-class-can-precede-p (cpl)
975 (let ((first (car cpl
)))
976 (dolist (c (cdr cpl
))
977 (pushnew c
(slot-value first
'can-precede-list
) :test
#'eq
)))
978 (update-class-can-precede-p (cdr cpl
))))
980 (defun class-can-precede-p (class1 class2
)
981 (member class2
(class-can-precede-list class1
) :test
#'eq
))
983 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
985 ;;; In addition to slot locations (implicit in the ordering of the slots), we
986 ;;; must check classes: SLOT-INFO structures from old slotds may have been
987 ;;; cached in permutation vectors, but new slotds have had new ones allocated
988 ;;; to them. This is non-problematic for standard slotds, because we know the
989 ;;; structure is compatible, but if a slot definition class changes, this can
990 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
992 ;;; Also, if the slot has a non-standard allocation, we need to check that it
994 (defun slot-layouts-compatible-p
995 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
996 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
997 (classify-slotds oslotds
)
999 ;; Instance slots: name, type, and class.
1000 (dolist (o old-instance-slotds
(not new-instance-slotds
))
1001 (let ((n (pop new-instance-slotds
)))
1003 (eq (slot-definition-name o
) (slot-definition-name n
))
1004 (eq (slot-definition-type o
) (slot-definition-type n
))
1005 (eq (class-of o
) (class-of n
)))
1007 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
1008 (dolist (o old-class-slotds
(not new-class-slotds
))
1009 (let ((n (pop new-class-slotds
)))
1011 (eq (slot-definition-name o
) (slot-definition-name n
))
1012 (eq (class-of n
) (class-of o
)))
1014 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
1015 (dolist (o old-custom-slotds
(not new-custom-slotds
))
1016 (let ((n (pop new-custom-slotds
)))
1018 (eq (slot-definition-name o
) (slot-definition-name n
))
1019 (eq (slot-definition-type o
) (slot-definition-type n
))
1020 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1021 (eq (class-of o
) (class-of n
)))
1024 (defun style-warn-about-duplicate-slots (class)
1025 (do* ((slots (slot-value class
'slots
) (cdr slots
))
1030 "~@<slot names with the same SYMBOL-NAME but ~
1031 different SYMBOL-PACKAGE (possible package problem) ~
1032 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1034 (let* ((slot-name (slot-definition-name (car slots
)))
1035 (oslots (and (not (eq (symbol-package slot-name
)
1038 (lambda (slot-name-2)
1039 (or (eq (symbol-package slot-name-2
)
1041 (string/= slot-name slot-name-2
)))
1043 :key
#'slot-definition-name
))))
1045 (pushnew (cons slot-name
1046 (mapcar #'slot-definition-name oslots
))
1048 :test
#'string
= :key
#'car
)))))
1050 (defun %update-slots
(class eslotds
)
1051 (multiple-value-bind (instance-slots class-slots custom-slots
)
1052 (classify-slotds eslotds
)
1053 (let* ((nslots (length instance-slots
))
1054 (owrapper (class-wrapper class
))
1056 (cond ((and owrapper
1057 (slot-layouts-compatible-p (layout-slot-list owrapper
)
1058 instance-slots class-slots custom-slots
))
1061 (not (class-finalized-p class
)))
1062 (make-wrapper nslots class
))
1064 ;; This will initialize the new wrapper to have the
1065 ;; same state as the old wrapper. We will then have
1066 ;; to change that. This may seem like wasted work
1067 ;; (and it is), but the spec requires that we call
1068 ;; MAKE-INSTANCES-OBSOLETE.
1069 (make-instances-obsolete class
)
1070 (class-wrapper class
)))))
1071 (%update-lisp-class-layout class nwrapper
)
1072 (setf (slot-value class
'slots
) eslotds
1073 (layout-slot-list nwrapper
) eslotds
1074 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1075 (layout-length nwrapper
) nslots
1076 (slot-value class
'wrapper
) nwrapper
)
1077 (style-warn-about-duplicate-slots class
)
1078 (setf (slot-value class
'finalized-p
) t
)
1079 (unless (eq owrapper nwrapper
)
1080 (maybe-update-standard-slot-locations class
)))))
1082 (defun update-gf-dfun (class gf
)
1083 (let ((*new-class
* class
)
1084 (arg-info (gf-arg-info gf
)))
1086 ((special-case-for-compute-discriminating-function-p gf
))
1087 ((gf-precompute-dfun-and-emf-p arg-info
)
1088 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1089 (update-dfun gf dfun cache info
))))))
1091 (defun update-gfs-of-class (class)
1092 (when (and (class-finalized-p class
)
1093 (let ((cpl (class-precedence-list class
)))
1094 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1095 (member *the-class-standard-effective-slot-definition
*
1097 (let ((gf-table (make-hash-table :test
'eq
)))
1098 (labels ((collect-gfs (class)
1099 (dolist (gf (specializer-direct-generic-functions class
))
1100 (setf (gethash gf gf-table
) t
))
1101 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1103 (maphash (lambda (gf ignore
)
1104 (declare (ignore ignore
))
1105 (update-gf-dfun class gf
))
1108 (defmethod compute-default-initargs ((class slot-class
))
1109 (let ((initargs (loop for c in
(class-precedence-list class
)
1110 append
(class-direct-default-initargs c
))))
1111 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1113 ;;;; protocols for constructing direct and effective slot definitions
1115 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1116 (declare (ignore initargs
))
1117 (find-class 'standard-direct-slot-definition
))
1119 (defun make-direct-slotd (class initargs
)
1120 (apply #'make-instance
1121 (apply #'direct-slot-definition-class class initargs
)
1125 ;;; I (CSR) am not sure, but I believe that the particular order of
1126 ;;; slots is quite important: it is ideal to attempt to have a
1127 ;;; constant slot location for the same notional slots as much as
1128 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1129 ;;; al.) have a chance of working. The below at least walks through
1130 ;;; the slots predictably, but maybe it would be good to compute some
1131 ;;; kind of optimal slot layout by looking at locations of slots in
1133 (defun std-compute-slots (class)
1134 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1135 ;; for each different slot name we find in our superclasses. Each
1136 ;; call receives the class and a list of the dslotds with that name.
1137 ;; The list is in most-specific-first order.
1138 (let ((name-dslotds-alist ()))
1139 (dolist (c (reverse (class-precedence-list class
)))
1140 (dolist (slot (class-direct-slots c
))
1141 (let* ((name (slot-definition-name slot
))
1142 (entry (assq name name-dslotds-alist
)))
1144 (push slot
(cdr entry
))
1145 (push (list name slot
) name-dslotds-alist
)))))
1146 (mapcar (lambda (direct)
1147 (compute-effective-slot-definition class
1150 (nreverse name-dslotds-alist
))))
1152 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1153 (defmethod compute-slots ((class standard-class
))
1154 (std-compute-slots class
))
1155 (defmethod compute-slots ((class funcallable-standard-class
))
1156 (std-compute-slots class
))
1157 (defmethod compute-slots ((class structure-class
))
1158 (std-compute-slots class
))
1159 (defmethod compute-slots ((class condition-class
))
1160 (std-compute-slots class
))
1162 (defun std-compute-slots-around (class eslotds
)
1164 (safe (safe-p class
)))
1165 (dolist (eslotd eslotds eslotds
)
1166 (setf (slot-definition-location eslotd
)
1167 (case (slot-definition-allocation eslotd
)
1171 (let* ((name (slot-definition-name eslotd
))
1174 (slot-definition-allocation-class eslotd
)
1175 ;; we get here if the user adds an extra slot
1177 (setf (slot-definition-allocation-class eslotd
)
1179 ;; which raises the question of what we should
1180 ;; do if we find that said user has added a slot
1181 ;; with the same name as another slot...
1182 (cell (or (assq name
(class-slot-cells from-class
))
1183 (let ((c (cons name
+slot-unbound
+)))
1184 (push c
(class-slot-cells from-class
))
1187 (if (eq +slot-unbound
+ (cdr cell
))
1188 ;; We may have inherited an initfunction FIXME: Is this
1189 ;; really right? Is the initialization in
1190 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1191 (let ((initfun (slot-definition-initfunction eslotd
)))
1193 (rplacd cell
(call-initfun initfun eslotd safe
))
1196 (unless (slot-definition-class eslotd
)
1197 (setf (slot-definition-class eslotd
) class
))
1198 (initialize-internal-slot-functions eslotd
))))
1200 (defmethod compute-slots :around
((class standard-class
))
1201 (let ((eslotds (call-next-method)))
1202 (std-compute-slots-around class eslotds
)))
1203 (defmethod compute-slots :around
((class funcallable-standard-class
))
1204 (let ((eslotds (call-next-method)))
1205 (std-compute-slots-around class eslotds
)))
1206 (defmethod compute-slots :around
((class structure-class
))
1207 (let ((eslotds (call-next-method)))
1208 (mapc #'finalize-internal-slot-functions eslotds
)
1211 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1212 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1213 (class (apply #'effective-slot-definition-class class initargs
))
1214 (slotd (apply #'make-instance class initargs
)))
1217 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1218 (declare (ignore initargs
))
1219 (find-class 'standard-effective-slot-definition
))
1221 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1222 (declare (ignore initargs
))
1223 (find-class 'structure-effective-slot-definition
))
1225 (defmethod compute-effective-slot-definition-initargs
1226 ((class slot-class
) direct-slotds
)
1232 (allocation-class nil
)
1235 (documentationp nil
)
1240 (dolist (slotd direct-slotds
)
1243 (setq name
(slot-definition-name slotd
)
1246 (awhen (slot-definition-initfunction slotd
)
1247 (setq initform
(slot-definition-initform slotd
)
1250 (unless documentationp
1251 (awhen (%slot-definition-documentation slotd
)
1252 (setq documentation it
1255 (setq allocation
(slot-definition-allocation slotd
)
1256 allocation-class
(slot-definition-class slotd
)
1258 (setq initargs
(append (slot-definition-initargs slotd
) initargs
))
1259 (let ((slotd-type (slot-definition-type slotd
)))
1261 ((eq type t
) slotd-type
)
1262 ;; This pairwise type intersection is perhaps a
1263 ;; little inefficient and inelegant, but it's
1264 ;; unlikely to lie on the critical path. Shout
1265 ;; if I'm wrong. -- CSR, 2005-11-24
1267 (specifier-type `(and ,type
,slotd-type
)))))))))
1270 :initfunction initfunction
1272 :allocation allocation
1273 :allocation-class allocation-class
1276 :documentation documentation
)))
1278 (defmethod compute-effective-slot-definition-initargs :around
1279 ((class structure-class
) direct-slotds
)
1280 (let* ((slotd (car direct-slotds
))
1281 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1282 (list* :defstruct-accessor-symbol accessor
1283 :internal-reader-function
1284 (slot-definition-internal-reader-function slotd
)
1285 :internal-writer-function
1286 (slot-definition-internal-writer-function slotd
)
1287 (call-next-method))))
1289 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1290 ;;; to make the method object. They have to use make-a-method which
1291 ;;; is a specially bootstrapped mechanism for making standard methods.
1292 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1293 (declare (ignore direct-slot initargs
))
1294 (find-class 'standard-reader-method
))
1296 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1297 (add-method generic-function
1298 (make-a-method 'standard-reader-method
1300 (list (or (class-name class
) 'object
))
1302 (make-reader-method-function class slot-name
)
1303 (or slot-documentation
"automatically generated reader method")
1304 :slot-name slot-name
1306 :method-class-function
#'reader-method-class
1307 :definition-source source-location
)))
1309 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1310 (declare (ignore direct-slot initargs
))
1311 (find-class 'standard-writer-method
))
1313 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1314 (add-method generic-function
1315 (make-a-method 'standard-writer-method
1317 (list 'new-value
(or (class-name class
) 'object
))
1318 (list *the-class-t
* class
)
1319 (make-writer-method-function class slot-name
)
1320 (or slot-documentation
"automatically generated writer method")
1321 :slot-name slot-name
1323 :method-class-function
#'writer-method-class
1324 :definition-source source-location
)))
1326 (defmethod add-boundp-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1327 (add-method generic-function
1328 (make-a-method (constantly (find-class 'standard-boundp-method
))
1331 (list (or (class-name class
) 'object
))
1333 (make-boundp-method-function class slot-name
)
1334 (or slot-documentation
"automatically generated boundp method")
1335 :slot-name slot-name
1336 :definition-source source-location
)))
1338 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1339 (let ((method (get-method generic-function
() (list class
) nil
)))
1340 (when method
(remove-method generic-function method
))))
1342 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1344 (get-method generic-function
() (list *the-class-t
* class
) nil
)))
1345 (when method
(remove-method generic-function method
))))
1347 (defmethod remove-boundp-method ((class slot-class
) generic-function
)
1348 (let ((method (get-method generic-function
() (list class
) nil
)))
1349 (when method
(remove-method generic-function method
))))
1351 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1352 ;;; function are NOT part of the standard protocol. They are however
1353 ;;; useful; PCL makes use of them internally and documents them for
1354 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1356 ;;; *** This needs work to make type testing by the writer functions which
1357 ;;; *** do type testing faster. The idea would be to have one constructor
1358 ;;; *** for each possible type test.
1360 ;;; *** There is a subtle bug here which is going to have to be fixed.
1361 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1362 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1363 ;;; *** defined for this metaclass a chance to run.
1365 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1366 (make-std-reader-method-function class slot-name
))
1368 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1369 (make-std-writer-method-function class slot-name
))
1371 (defmethod make-boundp-method-function ((class slot-class
) slot-name
)
1372 (make-std-boundp-method-function class slot-name
))
1374 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1375 (eq (class-of class
) (class-of proto-new-class
)))
1377 (defmethod validate-superclass ((class class
) (superclass class
))
1378 (or (eq (class-of class
) (class-of superclass
))
1379 (and (eq (class-of superclass
) *the-class-standard-class
*)
1380 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1381 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1382 (eq (class-of class
) *the-class-standard-class
*))))
1384 ;;; What this does depends on which of the four possible values of
1385 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1386 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1387 ;;; nothing to do, as the new wrapper has already been created. If
1388 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1389 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1390 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1392 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1393 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1394 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1395 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1396 ;;; obsolete the wrapper.
1398 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1399 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1400 ;;; :UNINITIALIZED)))
1402 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1403 (defun %force-cache-flushes
(class)
1405 (let* ((owrapper (class-wrapper class
)))
1406 ;; We only need to do something if the wrapper is still valid. If
1407 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1408 ;; both of those will already be doing what we want. In
1409 ;; particular, we must be sure we never change an OBSOLETE into a
1410 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1411 (when (or (not (invalid-wrapper-p owrapper
))
1412 ;; KLUDGE: despite the observations above, this remains
1413 ;; a violation of locality or what might be considered
1414 ;; good style. There has to be a better way! -- CSR,
1416 (eq (layout-invalid owrapper
) t
))
1417 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1419 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1420 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1421 (%update-lisp-class-layout class nwrapper
)
1422 (setf (slot-value class
'wrapper
) nwrapper
)
1423 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1425 (if (find-if (lambda (x)
1426 (and (consp x
) (eq :obsolete
(car x
))))
1427 (layout-inherits owrapper
)
1428 :key
#'layout-invalid
)
1429 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1430 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1433 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1434 ;;; the next access to the instance (as defined in 88-002R) to trap
1435 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1436 (defmethod make-instances-obsolete ((class std-class
))
1438 (let* ((owrapper (class-wrapper class
))
1439 (nwrapper (make-wrapper (layout-length owrapper
)
1441 (unless (class-finalized-p class
)
1442 (if (class-has-a-forward-referenced-superclass-p class
)
1443 (return-from make-instances-obsolete class
)
1444 (%update-cpl class
(compute-class-precedence-list class
))))
1445 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1446 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1447 (%update-lisp-class-layout class nwrapper
)
1448 (setf (slot-value class
'wrapper
) nwrapper
)
1449 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1452 (defmethod make-instances-obsolete ((class symbol
))
1453 (make-instances-obsolete (find-class class
))
1454 ;; ANSI wants the class name when called with a symbol.
1457 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1458 ;;; see an obsolete instance. The times when it is called are:
1459 ;;; - when the instance is involved in method lookup
1460 ;;; - when attempting to access a slot of an instance
1462 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1463 ;;; instance access macros.
1465 ;;; Of course these times when it is called are an internal
1466 ;;; implementation detail of PCL and are not part of the documented
1467 ;;; description of when the obsolete instance update happens. The
1468 ;;; documented description is as it appears in 88-002R.
1470 ;;; This has to return the new wrapper, so it counts on all the
1471 ;;; methods on obsolete-instance-trap-internal to return the new
1472 ;;; wrapper. It also does a little internal error checking to make
1473 ;;; sure that the traps are only happening when they should, and that
1474 ;;; the trap methods are computing appropriate new wrappers.
1476 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1477 ;;; after a structure is redefined. In most cases,
1478 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1479 ;;; so it must signal an error. The hard part of this is that the
1480 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1481 ;;; called again, so in that case, we have to return some reasonable
1482 ;;; wrapper, instead.
1484 (defun %ensure-slot-value-type
(context slot-name slot-type value
1485 old-class new-class
)
1486 (do () ((typep value slot-type
))
1488 (bad-type value slot-type
1489 "~@<Error during ~A. Current value in slot ~
1490 ~/sb-impl::print-symbol-with-prefix/ of an instance ~
1491 of ~S is ~S, which does not match the new slot type ~
1492 ~S in class ~S.~:@>"
1493 context slot-name old-class value slot-type new-class
)
1494 (use-value (new-value)
1495 :interactive read-evaluated-form
1496 :report
(lambda (stream)
1497 (format stream
"~@<Specify a new value to by used ~
1499 ~/sb-impl::print-symbol-with-prefix/ ~
1502 (setf value new-value
))))
1505 (defun %set-slot-value-checking-type
(context slots slot value
1506 safe old-class new-class
)
1507 (setf (clos-slots-ref slots
(slot-definition-location slot
))
1508 (if (and safe
(neq value
+slot-unbound
+))
1509 (let ((name (slot-definition-name slot
))
1510 (type (slot-definition-type slot
)))
1511 (%ensure-slot-value-type context name type value
1512 old-class new-class
))
1515 (defvar *in-obsolete-instance-trap
* nil
)
1516 (defvar *the-wrapper-of-structure-object
*
1517 (class-wrapper (find-class 'structure-object
)))
1519 (define-condition obsolete-structure
(error)
1520 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1522 (lambda (condition stream
)
1523 ;; Don't try to print the structure, since it probably won't work.
1525 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1526 (type-of (obsolete-structure-datum condition
))))))
1528 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1530 ((layout-for-std-class-p owrapper
)
1531 (binding* ((class (wrapper-class* nwrapper
))
1532 (copy (allocate-instance class
)) ;??? allocate-instance ???
1533 (oslots (get-slots instance
))
1534 (nslots (get-slots copy
))
1538 (safe (safe-p class
))
1539 ((new-instance-slots nil new-custom-slots
)
1540 (classify-slotds (layout-slot-list nwrapper
)))
1541 ((old-instance-slots old-class-slots old-custom-slots
)
1542 (classify-slotds (layout-slot-list owrapper
)))
1543 (layout (mapcar (lambda (slotd)
1544 ;; Get the names only once.
1545 (cons (slot-definition-name slotd
) slotd
))
1546 new-instance-slots
)))
1547 ;; local --> local transfer value, check type
1548 ;; local --> shared discard value, discard slot
1549 ;; local --> -- discard slot
1550 ;; local --> custom XXX
1552 ;; shared --> local transfer value, check type
1553 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1554 ;; shared --> -- discard value
1555 ;; shared --> custom XXX
1557 ;; -- --> local add slot
1559 ;; -- --> custom XXX
1560 (flet ((set-value (value cell
)
1561 (%set-slot-value-checking-type
1562 "updating obsolete instance"
1563 nslots
(cdr cell
) value safe class class
)
1564 ;; Prune from the list now that it's been dealt with.
1565 (setf layout
(remove cell layout
))))
1567 ;; Go through all the old local slots.
1568 (dolist (old old-instance-slots
)
1569 (let* ((name (slot-definition-name old
))
1570 (value (clos-slots-ref oslots
(slot-definition-location old
))))
1571 (unless (eq value
+slot-unbound
+)
1572 (let ((new (assq name layout
)))
1574 (set-value value new
))
1576 (push name discarded
)
1577 (setf (getf plist name
) value
)))))))
1579 ;; Go through all the old shared slots.
1580 (dolist (old old-class-slots
)
1581 (binding* ((cell (slot-definition-location old
))
1583 (new (assq name layout
) :exit-if-null
))
1584 (set-value (cdr cell
) new
)))
1586 ;; Go through all custom slots to find added ones. CLHS
1587 ;; doesn't specify what to do about them, and neither does
1588 ;; AMOP. We do want them to get initialized, though, so we
1589 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1590 (dolist (new new-custom-slots
)
1591 (let* ((name (slot-definition-name new
))
1592 (old (find name old-custom-slots
1593 :key
#'slot-definition-name
)))
1595 (push name added
))))
1597 ;; Go through all the remaining new local slots to compute
1599 (dolist (cell layout
)
1600 (push (car cell
) added
)))
1602 (%swap-wrappers-and-slots instance copy
)
1604 (update-instance-for-redefined-class
1605 instance added discarded plist
)
1608 (*in-obsolete-instance-trap
*
1609 *the-wrapper-of-structure-object
*)
1611 (let ((*in-obsolete-instance-trap
* t
))
1612 (error 'obsolete-structure
:datum instance
)))))
1615 (defun %change-class
(instance new-class initargs
)
1616 (declare (notinline allocate-instance
))
1617 (binding* ((old-class (class-of instance
))
1618 (copy (allocate-instance new-class
))
1619 (new-wrapper (get-wrapper copy
))
1620 (old-wrapper (class-wrapper old-class
))
1621 (old-slots (get-slots instance
))
1622 (new-slots (get-slots copy
))
1623 (safe (safe-p new-class
))
1624 (new-wrapper-slots (layout-slot-list new-wrapper
))
1625 (old-wrapper-slots (layout-slot-list old-wrapper
)))
1626 (labels ((find-instance-slot (name slots
)
1627 (loop for slot in slots
1628 when
(and (eq (slot-definition-allocation slot
) :instance
)
1629 (eq (slot-definition-name slot
) name
))
1631 (initarg-for-slot-p (slot)
1632 (dolist (slot-initarg (slot-definition-initargs slot
))
1633 ;; Abuse +slot-unbound+
1634 (unless (eq +slot-unbound
+
1635 (getf initargs slot-initarg
+slot-unbound
+))
1637 (set-value (value slotd
)
1638 (%set-slot-value-checking-type
1639 'change-class new-slots slotd value safe
1640 old-class new-class
)))
1642 ;; "The values of local slots specified by both the class CTO
1643 ;; and CFROM are retained. If such a local slot was unbound, it
1644 ;; remains unbound."
1645 (dolist (new new-wrapper-slots
)
1646 (when (and (not (initarg-for-slot-p new
))
1647 (eq (slot-definition-allocation new
) :instance
))
1648 (binding* ((old (find-instance-slot (slot-definition-name new
) old-wrapper-slots
)
1650 (value (clos-slots-ref old-slots
(slot-definition-location old
))))
1651 (set-value value new
))))
1653 ;; "The values of slots specified as shared in the class CFROM and
1654 ;; as local in the class CTO are retained."
1655 (dolist (old old-wrapper-slots
)
1656 (when (eq (slot-definition-allocation old
) :class
)
1657 (binding* ((slot-and-val (slot-definition-location old
))
1658 (new (find-instance-slot (car slot-and-val
) new-wrapper-slots
)
1660 (set-value (cdr slot-and-val
) new
)))))
1662 ;; Make the copy point to the old instance's storage, and make the
1663 ;; old instance point to the new storage.
1664 (%swap-wrappers-and-slots instance copy
)
1666 (apply #'update-instance-for-different-class copy instance initargs
)
1670 (defun check-new-class-not-metaobject (new-class)
1671 (dolist (class (class-precedence-list
1672 (ensure-class-finalized new-class
)))
1674 ((check-metaobject (class-name)
1675 `(when (eq class
(find-class ',class-name
))
1676 (change-class-to-metaobject-violation
1677 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1678 (check-metaobject class
)
1679 (check-metaobject generic-function
)
1680 (check-metaobject method
)
1681 (check-metaobject slot-definition
))))
1683 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1686 (check-new-class-not-metaobject new-class
)
1687 (%change-class instance new-class initargs
)))
1689 (defmethod change-class ((instance forward-referenced-class
)
1690 (new-class standard-class
) &rest initargs
)
1692 (dolist (class (class-precedence-list
1693 (ensure-class-finalized new-class
))
1694 (change-class-to-metaobject-violation
1695 '(not class
) 'forward-referenced-class
1696 '((:amop
:generic-function ensure-class-using-class
)
1697 (:amop
:initialization class
))))
1698 (when (eq class
(find-class 'class
))
1700 (%change-class instance new-class initargs
)))
1702 (defmethod change-class ((instance t
)
1703 (new-class forward-referenced-class
) &rest initargs
)
1704 (declare (ignore initargs
))
1705 (change-class-to-metaobject-violation
1706 'forward-referenced-class nil
1707 '((:amop
:generic-function ensure-class-using-class
)
1708 (:amop
:initialization class
))))
1710 (defmethod change-class ((instance funcallable-standard-object
)
1711 (new-class funcallable-standard-class
)
1714 (check-new-class-not-metaobject new-class
)
1715 (%change-class instance new-class initargs
)))
1717 (defmethod change-class ((instance standard-object
)
1718 (new-class funcallable-standard-class
)
1720 (declare (ignore initargs
))
1721 (error "You can't change the class of ~S to ~S~@
1722 because it isn't already an instance with metaclass ~S."
1723 instance new-class
'standard-class
))
1725 (defmethod change-class ((instance funcallable-standard-object
)
1726 (new-class standard-class
)
1728 (declare (ignore initargs
))
1729 (error "You can't change the class of ~S to ~S~@
1730 because it isn't already an instance with metaclass ~S."
1731 instance new-class
'funcallable-standard-class
))
1733 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1734 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1736 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1738 ;;;; These metaclasses are something of a weird creature. By this
1739 ;;;; point, all instances which will exist have been created, and no
1740 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1741 ;;;; distinction between the metaclasses is that we allow subclassing
1742 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1743 ;;;; but not of BUILT-IN-CLASS.)
1745 ;;;; AMOP mandates some behaviour of the implementation with respect
1746 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1747 ;;;; SYSTEM-CLASS here.
1749 (macrolet ((def (name args control
)
1750 `(defmethod ,name
,args
1751 (declare (ignore initargs
))
1752 (error 'metaobject-initialization-violation
1753 :format-control
,(coerce (format nil
"~@<~A~@:>" control
)
1755 :format-arguments
(list (class-name class
))
1756 :references
(list '(:amop
:initialization
"Class"))))))
1757 (def initialize-instance
((class system-class
) &rest initargs
)
1758 "Cannot initialize an instance of ~S.")
1759 (def reinitialize-instance
((class system-class
) &rest initargs
)
1760 "Cannot reinitialize an instance of ~S."))
1762 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1763 (def class-direct-slots
)
1765 (def class-direct-default-initargs
)
1766 (def class-default-initargs
))
1768 (defmethod validate-superclass ((c class
) (s system-class
))
1770 (defmethod validate-superclass ((c class
) (s built-in-class
))
1773 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1774 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1775 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1776 (macrolet ((def (method)
1777 `(defmethod ,method
((class forward-referenced-class
))
1778 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1780 (def class-default-initargs
)
1781 (def class-precedence-list
)
1784 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1787 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1788 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1790 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1791 (setf (plist-value metaobject
'dependents
)
1792 (delete dependent
(plist-value metaobject
'dependents
))))
1794 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1795 (dolist (dependent (plist-value metaobject
'dependents
))
1796 (funcall function dependent
)))