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 (sb-kernel::call-with-defining-class
332 (sb-kernel::%%compiler-defclass name readers writers slot-names
)
333 (apply #'ensure-class name
:metaclass metaclass-name
334 :direct-superclasses supers
336 :definition-source source-location
340 (setf (gdefinition 'load-defclass
) #'real-load-defclass
)
342 (defun ensure-class (name &rest args
)
344 (apply #'ensure-class-using-class
345 (let ((class (find-class name nil
)))
346 (when (and class
(eq name
(class-name class
)))
347 ;; NAME is the proper name of CLASS, so redefine it
351 (defun parse-ensure-class-args (class name args
)
352 (let ((metaclass *the-class-standard-class
*)
354 (reversed-plist '()))
355 (labels ((find-class* (which class-or-name
)
357 ((classp class-or-name
)
359 ((eq class-or-name class
)
360 (error "~@<Class ~A specified as its own ~
362 class-or-name which
))
365 ((and class-or-name
(legal-class-name-p class-or-name
))
367 ((eq class-or-name name
)
368 (error "~@<Class named ~
369 ~/sb-impl::print-symbol-with-prefix/ ~
370 specified as its own ~(~A~)class.~@:>"
371 class-or-name which
))
372 ((find-class class-or-name
(eq which
:meta
)))
374 class-or-name
:metaclass
'forward-referenced-class
))))
376 (error "~@<Not a class or a legal ~(~A~)class name: ~
378 which class-or-name
))))
379 (find-superclass (class-or-name)
380 (find-class* :super class-or-name
)))
381 (doplist (key value
) args
385 (setf metaclass
(find-class* :meta value
)
387 (:direct-superclasses
388 (let ((superclasses (mapcar #'find-superclass value
)))
389 (setf reversed-plist
(list* superclasses key reversed-plist
))))
391 (setf reversed-plist
(list* value key reversed-plist
)))))
392 (values metaclass
(nreverse reversed-plist
)))))
394 (defun call-with-ensure-class-context (class name args thunk
)
395 (let ((class (with-world-lock ()
396 (multiple-value-bind (metaclass initargs
)
397 (parse-ensure-class-args class name args
)
398 (let ((class (funcall thunk class name metaclass initargs
)))
399 (without-package-locks
400 (setf (find-class name
) class
)))))))
403 (defmethod ensure-class-using-class ((class null
) name
&rest args
&key
)
404 (call-with-ensure-class-context
405 class name args
(lambda (class name metaclass initargs
)
406 (declare (ignore class
))
407 (apply #'make-instance metaclass
:name name initargs
))))
409 (defmethod ensure-class-using-class ((class pcl-class
) name
&rest args
&key
)
410 (call-with-ensure-class-context
411 class name args
(lambda (class name metaclass initargs
)
412 (aver (eq name
(class-name class
)))
413 (unless (eq (class-of class
) metaclass
)
414 (apply #'change-class class metaclass initargs
))
415 (apply #'reinitialize-instance class initargs
)
418 ;;; This is used to call initfunctions of :allocation :class slots.
419 (defun call-initfun (fun slotd safe
)
420 (declare (function fun
))
421 (let ((value (funcall fun
)))
423 (let ((type (slot-definition-type slotd
)))
424 (unless (or (eq t type
)
426 (error 'type-error
:expected-type type
:datum value
))))
429 (defmethod shared-initialize :after
430 ((class std-class
) slot-names
&key
431 (direct-superclasses nil direct-superclasses-p
)
432 (direct-slots nil direct-slots-p
)
433 (direct-default-initargs nil direct-default-initargs-p
))
434 (cond (direct-superclasses-p
435 (setq direct-superclasses
436 (or direct-superclasses
437 (list (if (funcallable-standard-class-p class
)
438 *the-class-funcallable-standard-object
*
439 *the-class-standard-object
*))))
440 (dolist (superclass direct-superclasses
)
441 (unless (validate-superclass class superclass
)
442 (invalid-superclass class superclass
)))
443 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
445 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
448 (setf (slot-value class
'direct-slots
)
449 (mapcar (lambda (pl) (make-direct-slotd class pl
))
451 (slot-value class
'direct-slots
)))
452 (if direct-default-initargs-p
453 (setf (plist-value class
'direct-default-initargs
)
454 direct-default-initargs
)
455 (setq direct-default-initargs
456 (plist-value class
'direct-default-initargs
)))
457 (setf (plist-value class
'class-slot-cells
)
458 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
459 (safe (safe-p class
))
461 (dolist (dslotd direct-slots
)
462 (when (eq :class
(slot-definition-allocation dslotd
))
464 (let* ((name (slot-definition-name dslotd
))
465 (old (assoc name old-class-slot-cells
)))
468 (member name slot-names
:test
#'eq
))
469 (let* ((initfunction (slot-definition-initfunction dslotd
))
472 (call-initfun initfunction dslotd safe
)
474 (push (cons name value
) collect
))
475 (push old collect
)))))
477 (add-direct-subclasses class direct-superclasses
)
478 (if (class-finalized-p class
)
479 ;; required by AMOP, "Reinitialization of Class Metaobjects"
480 (finalize-inheritance class
)
481 (update-class class nil
))
482 (add-slot-accessors class direct-slots
)
483 (make-preliminary-layout class
))
485 (define-condition invalid-superclass
(reference-condition error
)
486 ((class :initarg
:class
:reader invalid-superclass-class
)
487 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
490 (let ((class (invalid-superclass-class c
))
491 (superclass (invalid-superclass-superclass c
)))
493 "~@<The class ~S was specified as a superclass of the ~
494 class ~S, but the metaclasses ~S and ~S are ~
495 incompatible.~@[ Define a method for ~S to avoid this ~
497 superclass class
(class-of superclass
) (class-of class
)
498 (and (typep superclass
'standard-class
)
499 'validate-superclass
))))))
501 (defmethod invalid-superclass ((class class
) (superclass class
))
502 (error 'invalid-superclass
:class class
:superclass superclass
503 :references
(list* '(:amop
:generic-function validate-superclass
)
504 (and (typep superclass
'built-in-class
)
505 (list '(:ansi-cl
:system-class built-in-class
)
506 '(:ansi-cl
:section
(4 3 7)))))))
508 (defmethod shared-initialize :after
((class forward-referenced-class
)
509 slot-names
&key
&allow-other-keys
)
510 (declare (ignore slot-names
))
511 (make-preliminary-layout class
))
513 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
515 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
516 ;;; make it known to the type system.
517 (defun make-preliminary-layout (class)
518 (flet ((compute-preliminary-cpl (root)
519 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
520 (compute-class-precedence-list root
))))
522 (without-package-locks
523 (unless (class-finalized-p class
)
524 (let ((name (class-name class
))) ; flushable?
525 (declare (ignore name
))
526 ;; KLUDGE: This is fairly horrible. We need to make a
527 ;; full-fledged CLASSOID here, not just tell the compiler that
528 ;; some class is forthcoming, because there are legitimate
529 ;; questions one can ask of the type system, implemented in
530 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
531 (let ((layout (make-wrapper 0 class
)))
532 (setf (slot-value class
'wrapper
) layout
)
533 (let ((cpl (compute-preliminary-cpl class
)))
534 (setf (layout-inherits layout
)
535 (order-layout-inherits
536 (map 'simple-vector
#'class-wrapper
537 (reverse (rest cpl
))))))
538 (register-layout layout
:invalidate t
))))
539 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
542 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
543 (declare (ignore slot-names name
))
544 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
545 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
546 (setf (slot-value class
'%type
) `(class ,class
))
547 (setf (slot-value class
'class-eq-specializer
)
548 (make-instance 'class-eq-specializer
:class class
)))
550 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
551 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
552 (remove-direct-subclass old-super class
))
553 (remove-slot-accessors class
(class-direct-slots class
)))
555 (defmethod reinitialize-instance :after
((class slot-class
)
558 (map-dependents class
560 (apply #'update-dependent class dependent initargs
))))
562 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
563 (let* ((name (class-name class
))
564 (classoid (find-classoid name
))
565 (slots (condition-classoid-slots classoid
))
566 (source (sb-kernel::layout-source-location
(classoid-layout classoid
))))
567 ;; to balance the REMOVE-SLOT-ACCESSORS call in
568 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
569 (flet ((add-source-location (method)
571 (setf (slot-value method
'source
) source
))))
573 (let ((slot-name (condition-slot-name slot
)))
574 (dolist (reader (condition-slot-readers slot
))
575 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
576 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
578 (sb-kernel::install-condition-slot-reader reader name slot-name
)))
579 (dolist (writer (condition-slot-writers slot
))
581 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))))
583 (defmethod shared-initialize :after
((class condition-class
) slot-names
584 &key direct-slots direct-superclasses
)
585 (declare (ignore slot-names
))
586 (let ((classoid (find-classoid (slot-value class
'name
))))
588 %class-precedence-list cpl-available-p finalized-p
589 prototype
(direct-supers direct-superclasses
)
592 (setf (slot-value class
'direct-slots
)
593 (mapcar (lambda (pl) (make-direct-slotd class pl
))
596 (classoid-pcl-class classoid
) class
597 direct-supers direct-superclasses
598 wrapper
(classoid-layout classoid
)
599 %class-precedence-list
(compute-class-precedence-list class
)
601 (getf plist
'direct-default-initargs
)
602 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
603 (add-direct-subclasses class direct-superclasses
)
604 (let ((slots (compute-slots class
)))
605 (setf (slot-value class
'slots
) slots
)
606 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
607 ;; Comment from Gerd's PCL, 2003-05-15:
609 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
610 ;; override condition accessors with generic functions. We do this
613 ;; ??? What does the above comment mean and why is it a good idea?
614 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
615 ;; comment) loses slot information in its condition classes:
616 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
617 ;; remove slot accessors but never put them back. I've added a
618 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
619 ;; was meant to happen? -- CSR, 2005-11-18
622 (defmethod direct-slot-definition-class ((class condition-class
)
624 (declare (ignore initargs
))
625 (find-class 'condition-direct-slot-definition
))
627 (defmethod effective-slot-definition-class ((class condition-class
)
629 (declare (ignore initargs
))
630 (find-class 'condition-effective-slot-definition
))
632 (defmethod finalize-inheritance ((class condition-class
))
633 (aver (slot-value class
'finalized-p
))
636 (defmethod compute-effective-slot-definition
637 ((class condition-class
) slot-name dslotds
)
638 (let* ((slotd (call-next-method))
639 (info (slot-definition-info slotd
)))
640 (setf (slot-info-reader info
)
642 (handler-case (condition-slot-value x slot-name
)
643 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
644 ;; is unbound; maybe it should be a CELL-ERROR of some
646 (error () (values (slot-unbound class x slot-name
))))))
647 (setf (slot-info-writer info
)
649 (set-condition-slot-value x v slot-name
)))
650 (setf (slot-info-boundp info
)
652 (multiple-value-bind (v c
)
653 (ignore-errors (condition-slot-value x slot-name
))
658 (defmethod compute-slots :around
((class condition-class
))
659 (let ((eslotds (call-next-method)))
660 (mapc #'finalize-internal-slot-functions eslotds
)
663 (defmethod shared-initialize :after
664 ((slotd structure-slot-definition
) slot-names
&key
665 (allocation :instance
) allocation-class
)
666 (declare (ignore slot-names allocation-class
))
667 (unless (eq allocation
:instance
)
668 (error "Structure slots must have :INSTANCE allocation.")))
670 (defun make-structure-class-defstruct-form (name direct-slots include
)
671 (let* ((conc-name (format-symbol *package
* "~S structure class " name
))
672 (constructor (format-symbol *package
* "~Aconstructor" conc-name
))
673 (included-name (class-name include
))
676 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
681 (dolist (slotd (reverse direct-slots
))
682 (let* ((slot-name (slot-definition-name slotd
))
683 (initform (slot-definition-initform slotd
))
684 (type (slot-definition-type slotd
))
685 (desc `(,slot-name
,initform
:type
,type
)))
686 (push `(slot-accessor ,name
,slot-name reader
)
688 (push `(slot-accessor ,name
,slot-name writer
)
690 (if (member slot-name included-slots
:test
#'eq
)
691 (push desc old-slots
)
692 (push desc new-slots
))))
693 (let* ((defstruct `(defstruct (,name
695 `((:include
,included-name
697 (:constructor
,constructor
())
699 (:conc-name
,conc-name
)
703 (mapcar (lambda (slotd reader-name
)
705 (slot-definition-defstruct-accessor-symbol
707 `(defun ,reader-name
(obj)
708 (declare (type ,name obj
))
710 direct-slots reader-names
))
712 (mapcar (lambda (slotd writer-name
)
714 (slot-definition-defstruct-accessor-symbol
716 `(defun ,writer-name
(nv obj
)
717 (declare (type ,name obj
))
718 (setf (,accessor obj
) nv
))))
719 direct-slots writer-names
))
723 ,@readers-init
,@writers-init
725 (values defstruct-form constructor reader-names writer-names
))))
727 ;;; Return a thunk to allocate an instance of CLASS named NAME.
728 ;;; This is broken with regard to the expectation that all semantic
729 ;;; processing is done by the compiler. e.g. after COMPILE-FILE on
730 ;;; a file containing these two toplevel forms:
731 ;;; (eval-when (:compile-toplevel) (defmacro maker () '(list 1)))
732 ;;; (defstruct foo (a (maker)))
733 ;;; then LOADing the resulting fasl in a fresh image will err:
734 ;;; (make-instance 'foo) => "The function MAKER is undefined."
736 ;;; The way to fix that is to ensure that every defstruct has a zero-argument
737 ;;; constructor made by the compiler and stashed in a random symbol.
738 (defun make-defstruct-allocation-function (name class
)
739 (declare (muffle-conditions code-deletion-note
))
740 ;; FIXME: Why don't we go class->layout->info == dd
741 (let ((dd (find-defstruct-description name
)))
744 ;; This used to call COMPILE directly, which is basically pointless,
745 ;; because it certainly does not avoid compiling code at runtime,
746 ;; which seems to have been the goal. We're also compiling:
747 ;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #<STRUCTURE-CLASS THING>))
748 ;; So maybe we can figure out how to bundle two lambdas together?
750 (let* ((dd (layout-info (class-wrapper class
)))
751 (f (%make-structure-instance-allocator dd nil
)))
753 (funcall (setf (slot-value class
'defstruct-constructor
) f
))
754 (error "Can't allocate ~S" class
)))))
755 (funcallable-structure
756 ;; FIXME: you can't dynamically define new funcallable structures
757 ;; that are not GENERIC-FUNCTION subtypes, so why this branch?
758 ;; We should pull this out, fixup PCL bootstrap, and not pretend
759 ;; that this code is more general than it really is.
760 (%make-funcallable-structure-instance-allocator dd nil
)))))
762 (defmethod shared-initialize :after
763 ((class structure-class
) slot-names
&key
764 (direct-superclasses nil direct-superclasses-p
)
765 (direct-slots nil direct-slots-p
)
766 direct-default-initargs
)
767 (declare (ignore slot-names direct-default-initargs
))
768 (if direct-superclasses-p
769 (setf (slot-value class
'direct-superclasses
)
770 (or direct-superclasses
771 (setq direct-superclasses
772 (and (not (eq (slot-value class
'name
) 'structure-object
))
773 (list *the-class-structure-object
*)))))
774 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
775 (let* ((name (slot-value class
'name
))
776 (from-defclass-p (slot-value class
'from-defclass-p
))
777 ;; DEFSTRUCT-P means we should perform the effect of DEFSTRUCT,
778 ;; and not that this structure came from a DEFSTRUCT.
779 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
781 (setf (slot-value class
'direct-slots
)
785 (let* ((slot-name (getf pl
:name
))
787 (format-symbol *package
*
788 "~S structure class ~A"
790 (setq pl
(list* :defstruct-accessor-symbol
792 (make-direct-slotd class pl
))
794 (setq direct-slots
(slot-value class
'direct-slots
)))
796 (let ((include (car (slot-value class
'direct-superclasses
))))
797 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
798 (make-structure-class-defstruct-form name direct-slots include
)
799 (unless (structure-type-p name
) (eval defstruct-form
))
800 (mapc (lambda (dslotd reader-name writer-name
)
801 (let* ((reader (gdefinition reader-name
))
802 (writer (when (fboundp writer-name
)
803 (gdefinition writer-name
))))
804 (setf (slot-value dslotd
'internal-reader-function
)
806 (setf (slot-value dslotd
'internal-writer-function
)
808 direct-slots reader-names writer-names
)
809 (setf (slot-value class
'defstruct-form
) defstruct-form
)
810 (setf (slot-value class
'defstruct-constructor
) constructor
)))
811 ;; FIXME: If we always need a default constructor, then why not just make
812 ;; a "hidden" one at actual-compile-time and store it?
813 ;; And this is very broken with regard to the lexical environment.
814 ;; And why isn't this just DD-DEFAULT-CONSTRUCTOR if there was one?
815 (setf (slot-value class
'defstruct-constructor
)
816 ;; KLUDGE: not class; in fixup.lisp, can't access slots
817 ;; outside methods yet.
818 (make-defstruct-allocation-function name class
)))
819 (add-direct-subclasses class direct-superclasses
)
820 (setf (slot-value class
'%class-precedence-list
)
821 (compute-class-precedence-list class
))
822 (setf (slot-value class
'cpl-available-p
) t
)
823 (let ((slots (compute-slots class
)))
824 (setf (slot-value class
'slots
) slots
)
825 (let* ((lclass (find-classoid (slot-value class
'name
)))
826 (layout (classoid-layout lclass
)))
827 (setf (classoid-pcl-class lclass
) class
)
828 (setf (slot-value class
'wrapper
) layout
)
829 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
830 (setf (slot-value class
'finalized-p
) t
)
831 (add-slot-accessors class direct-slots
)))
833 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
834 (declare (ignore initargs
))
835 (find-class 'structure-direct-slot-definition
))
837 (defmethod finalize-inheritance ((class structure-class
))
838 nil
) ; always finalized
840 (defun add-slot-accessors (class dslotds
)
841 (fix-slot-accessors class dslotds
'add
))
843 (defun remove-slot-accessors (class dslotds
)
844 (fix-slot-accessors class dslotds
'remove
))
846 (defun fix-slot-accessors (class dslotds add
/remove
)
847 (flet ((fix (gfspec name r
/w doc source-location
)
848 (let ((gf (cond ((eq add
/remove
'add
)
849 (or (find-generic-function gfspec nil
)
850 (ensure-generic-function
851 gfspec
:lambda-list
(case r
/w
853 (w '(new-value object
))))))
855 (find-generic-function gfspec nil
)))))
858 (r (if (eq add
/remove
'add
)
859 (add-reader-method class gf name doc source-location
)
860 (remove-reader-method class gf
)))
861 (w (if (eq add
/remove
'add
)
862 (add-writer-method class gf name doc source-location
)
863 (remove-writer-method class gf
))))))))
864 (dolist (dslotd dslotds
)
865 (let ((slot-name (slot-definition-name dslotd
))
866 (slot-doc (%slot-definition-documentation dslotd
))
867 (location (definition-source dslotd
)))
868 (dolist (r (slot-definition-readers dslotd
))
869 (fix r slot-name
'r slot-doc location
))
870 (dolist (w (slot-definition-writers dslotd
))
871 (fix w slot-name
'w slot-doc location
))))))
873 (defun add-direct-subclasses (class supers
)
874 (dolist (super supers
)
875 (unless (memq class
(class-direct-subclasses class
))
876 (add-direct-subclass super class
))))
878 (defmethod finalize-inheritance ((class std-class
))
879 (update-class class t
))
881 (defmethod finalize-inheritance ((class forward-referenced-class
))
882 ;; FIXME: should we not be thinking a bit about what kinds of error
883 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
884 ;; possibly a forward-referenced-class-error, though that's
885 ;; difficult given e.g. class precedence list calculations...
887 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
892 (defun class-has-a-forward-referenced-superclass-p (class)
893 (or (when (forward-referenced-class-p class
)
895 (some #'class-has-a-forward-referenced-superclass-p
896 (class-direct-superclasses class
))))
898 ;;; This is called by :after shared-initialize whenever a class is initialized
899 ;;; or reinitialized. The class may or may not be finalized.
900 (defun update-class (class finalizep
)
901 (labels ((rec (class finalizep
&optional
(seen '()))
902 (when (find class seen
:test
#'eq
)
903 (error "~@<Specified class ~S as a superclass of ~
906 (without-package-locks
908 (when (or finalizep
(class-finalized-p class
))
909 (%update-cpl class
(compute-class-precedence-list class
))
910 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
912 (%update-slots class
(compute-slots class
))
913 (update-gfs-of-class class
)
914 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
915 (update-ctors 'finalize-inheritance
:class class
))
916 (let ((seen (list* class seen
)))
917 (dolist (sub (class-direct-subclasses class
))
918 (rec sub nil seen
)))))))
919 (rec class finalizep
)))
921 (define-condition cpl-protocol-violation
(reference-condition error
)
922 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
923 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
924 (:default-initargs
:references
(list '(:sbcl
:node
"Metaobject Protocol")))
927 (format s
"~@<Protocol violation: the ~S class ~S ~
928 ~:[has~;does not have~] the class ~S in its ~
929 class precedence list: ~S.~@:>"
930 (class-name (class-of (cpl-protocol-violation-class c
)))
931 (cpl-protocol-violation-class c
)
932 (eq (class-of (cpl-protocol-violation-class c
))
933 *the-class-funcallable-standard-class
*)
934 (find-class 'function
)
935 (cpl-protocol-violation-cpl c
)))))
937 (defun class-has-a-cpl-protocol-violation-p (class)
938 (labels ((find-in-superclasses (class classes
)
941 ((eql class
(car classes
)) t
)
942 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
943 (let ((metaclass (class-of class
)))
945 ((eql metaclass
*the-class-standard-class
*)
946 (find-in-superclasses (find-class 'function
) (list class
)))
947 ((eql metaclass
*the-class-funcallable-standard-class
*)
948 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
950 (defun %update-cpl
(class cpl
)
952 (eq (class-of class
) *the-class-standard-class
*)
953 (find *the-class-function
* cpl
))
954 (and (eq (class-of class
) *the-class-funcallable-standard-class
*)
955 (not (and (find (find-class 'function
) cpl
)))))
956 (error 'cpl-protocol-violation
:class class
:cpl cpl
))
957 (cond ((not (class-finalized-p class
))
958 (setf (slot-value class
'%class-precedence-list
) cpl
959 (slot-value class
'cpl-available-p
) t
))
960 ((not (and (equal (class-precedence-list class
) cpl
)
962 (when (position :class
(class-direct-slots c
)
963 :key
#'slot-definition-allocation
)
966 ;; comment from the old CMU CL sources:
967 ;; Need to have the cpl setup before %update-lisp-class-layout
968 ;; is called on CMU CL.
969 (setf (slot-value class
'%class-precedence-list
) cpl
970 (slot-value class
'cpl-available-p
) t
)
971 (%force-cache-flushes class
)))
972 (update-class-can-precede-p cpl
))
974 (defun update-class-can-precede-p (cpl)
976 (let ((first (car cpl
)))
977 (dolist (c (cdr cpl
))
978 (pushnew c
(slot-value first
'can-precede-list
) :test
#'eq
)))
979 (update-class-can-precede-p (cdr cpl
))))
981 (defun class-can-precede-p (class1 class2
)
982 (member class2
(class-can-precede-list class1
) :test
#'eq
))
984 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
986 ;;; In addition to slot locations (implicit in the ordering of the slots), we
987 ;;; must check classes: SLOT-INFO structures from old slotds may have been
988 ;;; cached in permutation vectors, but new slotds have had new ones allocated
989 ;;; to them. This is non-problematic for standard slotds, because we know the
990 ;;; structure is compatible, but if a slot definition class changes, this can
991 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
993 ;;; Also, if the slot has a non-standard allocation, we need to check that it
995 (defun slot-layouts-compatible-p
996 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
997 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
998 (classify-slotds oslotds
)
1000 ;; Instance slots: name, type, and class.
1001 (dolist (o old-instance-slotds
(not new-instance-slotds
))
1002 (let ((n (pop new-instance-slotds
)))
1004 (eq (slot-definition-name o
) (slot-definition-name n
))
1005 (eq (slot-definition-type o
) (slot-definition-type n
))
1006 (eq (class-of o
) (class-of n
)))
1008 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
1009 (dolist (o old-class-slotds
(not new-class-slotds
))
1010 (let ((n (pop new-class-slotds
)))
1012 (eq (slot-definition-name o
) (slot-definition-name n
))
1013 (eq (class-of n
) (class-of o
)))
1015 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
1016 (dolist (o old-custom-slotds
(not new-custom-slotds
))
1017 (let ((n (pop new-custom-slotds
)))
1019 (eq (slot-definition-name o
) (slot-definition-name n
))
1020 (eq (slot-definition-type o
) (slot-definition-type n
))
1021 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1022 (eq (class-of o
) (class-of n
)))
1025 (defun style-warn-about-duplicate-slots (class)
1026 (do* ((slots (slot-value class
'slots
) (cdr slots
))
1031 "~@<slot names with the same SYMBOL-NAME but ~
1032 different SYMBOL-PACKAGE (possible package problem) ~
1033 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1035 (let* ((slot-name (slot-definition-name (car slots
)))
1036 (oslots (and (not (eq (symbol-package slot-name
)
1039 (lambda (slot-name-2)
1040 (or (eq (symbol-package slot-name-2
)
1042 (string/= slot-name slot-name-2
)))
1044 :key
#'slot-definition-name
))))
1046 (pushnew (cons slot-name
1047 (mapcar #'slot-definition-name oslots
))
1049 :test
#'string
= :key
#'car
)))))
1051 (defun %update-slots
(class eslotds
)
1052 (multiple-value-bind (instance-slots class-slots custom-slots
)
1053 (classify-slotds eslotds
)
1054 (let* ((nslots (length instance-slots
))
1055 (owrapper (class-wrapper class
))
1057 (cond ((and owrapper
1058 (slot-layouts-compatible-p (layout-slot-list owrapper
)
1059 instance-slots class-slots custom-slots
))
1062 (not (class-finalized-p class
)))
1063 (make-wrapper nslots class
))
1065 ;; This will initialize the new wrapper to have the
1066 ;; same state as the old wrapper. We will then have
1067 ;; to change that. This may seem like wasted work
1068 ;; (and it is), but the spec requires that we call
1069 ;; MAKE-INSTANCES-OBSOLETE.
1070 (make-instances-obsolete class
)
1071 (class-wrapper class
)))))
1072 (%update-lisp-class-layout class nwrapper
)
1073 (setf (slot-value class
'slots
) eslotds
1074 (layout-slot-list nwrapper
) eslotds
1075 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1076 (layout-length nwrapper
) nslots
1077 (slot-value class
'wrapper
) nwrapper
)
1078 (style-warn-about-duplicate-slots class
)
1079 (setf (slot-value class
'finalized-p
) t
)
1080 (unless (eq owrapper nwrapper
)
1081 (maybe-update-standard-slot-locations class
)))))
1083 (defun update-gf-dfun (class gf
)
1084 (let ((*new-class
* class
)
1085 (arg-info (gf-arg-info gf
)))
1087 ((special-case-for-compute-discriminating-function-p gf
))
1088 ((gf-precompute-dfun-and-emf-p arg-info
)
1089 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1090 (update-dfun gf dfun cache info
))))))
1092 (defun update-gfs-of-class (class)
1093 (when (and (class-finalized-p class
)
1094 (let ((cpl (class-precedence-list class
)))
1095 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1096 (member *the-class-standard-effective-slot-definition
*
1098 (let ((gf-table (make-hash-table :test
'eq
)))
1099 (labels ((collect-gfs (class)
1100 (dolist (gf (specializer-direct-generic-functions class
))
1101 (setf (gethash gf gf-table
) t
))
1102 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1104 (maphash (lambda (gf ignore
)
1105 (declare (ignore ignore
))
1106 (update-gf-dfun class gf
))
1109 (defmethod compute-default-initargs ((class slot-class
))
1110 (let ((initargs (loop for c in
(class-precedence-list class
)
1111 append
(class-direct-default-initargs c
))))
1112 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1114 ;;;; protocols for constructing direct and effective slot definitions
1116 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1117 (declare (ignore initargs
))
1118 (find-class 'standard-direct-slot-definition
))
1120 (defun make-direct-slotd (class initargs
)
1121 (apply #'make-instance
1122 (apply #'direct-slot-definition-class class initargs
)
1126 ;;; I (CSR) am not sure, but I believe that the particular order of
1127 ;;; slots is quite important: it is ideal to attempt to have a
1128 ;;; constant slot location for the same notional slots as much as
1129 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1130 ;;; al.) have a chance of working. The below at least walks through
1131 ;;; the slots predictably, but maybe it would be good to compute some
1132 ;;; kind of optimal slot layout by looking at locations of slots in
1134 (defun std-compute-slots (class)
1135 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1136 ;; for each different slot name we find in our superclasses. Each
1137 ;; call receives the class and a list of the dslotds with that name.
1138 ;; The list is in most-specific-first order.
1139 (let ((name-dslotds-alist ()))
1140 (dolist (c (reverse (class-precedence-list class
)))
1141 (dolist (slot (class-direct-slots c
))
1142 (let* ((name (slot-definition-name slot
))
1143 (entry (assq name name-dslotds-alist
)))
1145 (push slot
(cdr entry
))
1146 (push (list name slot
) name-dslotds-alist
)))))
1147 (mapcar (lambda (direct)
1148 (compute-effective-slot-definition class
1151 (nreverse name-dslotds-alist
))))
1153 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1154 (defmethod compute-slots ((class standard-class
))
1155 (std-compute-slots class
))
1156 (defmethod compute-slots ((class funcallable-standard-class
))
1157 (std-compute-slots class
))
1158 (defmethod compute-slots ((class structure-class
))
1159 (std-compute-slots class
))
1160 (defmethod compute-slots ((class condition-class
))
1161 (std-compute-slots class
))
1163 (defun std-compute-slots-around (class eslotds
)
1165 (safe (safe-p class
)))
1166 (dolist (eslotd eslotds eslotds
)
1167 (setf (slot-definition-location eslotd
)
1168 (case (slot-definition-allocation eslotd
)
1172 (let* ((name (slot-definition-name eslotd
))
1175 (slot-definition-allocation-class eslotd
)
1176 ;; we get here if the user adds an extra slot
1178 (setf (slot-definition-allocation-class eslotd
)
1180 ;; which raises the question of what we should
1181 ;; do if we find that said user has added a slot
1182 ;; with the same name as another slot...
1183 (cell (or (assq name
(class-slot-cells from-class
))
1184 (let ((c (cons name
+slot-unbound
+)))
1185 (push c
(class-slot-cells from-class
))
1188 (if (eq +slot-unbound
+ (cdr cell
))
1189 ;; We may have inherited an initfunction FIXME: Is this
1190 ;; really right? Is the initialization in
1191 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1192 (let ((initfun (slot-definition-initfunction eslotd
)))
1194 (rplacd cell
(call-initfun initfun eslotd safe
))
1197 (unless (slot-definition-class eslotd
)
1198 (setf (slot-definition-class eslotd
) class
))
1199 (initialize-internal-slot-functions eslotd
))))
1201 (defmethod compute-slots :around
((class standard-class
))
1202 (let ((eslotds (call-next-method)))
1203 (std-compute-slots-around class eslotds
)))
1204 (defmethod compute-slots :around
((class funcallable-standard-class
))
1205 (let ((eslotds (call-next-method)))
1206 (std-compute-slots-around class eslotds
)))
1207 (defmethod compute-slots :around
((class structure-class
))
1208 (let ((eslotds (call-next-method)))
1209 (mapc #'finalize-internal-slot-functions eslotds
)
1212 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1213 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1214 (class (apply #'effective-slot-definition-class class initargs
))
1215 (slotd (apply #'make-instance class initargs
)))
1218 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1219 (declare (ignore initargs
))
1220 (find-class 'standard-effective-slot-definition
))
1222 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1223 (declare (ignore initargs
))
1224 (find-class 'structure-effective-slot-definition
))
1226 (defmethod compute-effective-slot-definition-initargs
1227 ((class slot-class
) direct-slotds
)
1233 (allocation-class nil
)
1236 (documentationp nil
)
1241 (dolist (slotd direct-slotds
)
1244 (setq name
(slot-definition-name slotd
)
1247 (awhen (slot-definition-initfunction slotd
)
1248 (setq initform
(slot-definition-initform slotd
)
1251 (unless documentationp
1252 (awhen (%slot-definition-documentation slotd
)
1253 (setq documentation it
1256 (setq allocation
(slot-definition-allocation slotd
)
1257 allocation-class
(slot-definition-class slotd
)
1259 (setq initargs
(append (slot-definition-initargs slotd
) initargs
))
1260 (let ((slotd-type (slot-definition-type slotd
)))
1262 ((eq type t
) slotd-type
)
1263 ;; This pairwise type intersection is perhaps a
1264 ;; little inefficient and inelegant, but it's
1265 ;; unlikely to lie on the critical path. Shout
1266 ;; if I'm wrong. -- CSR, 2005-11-24
1268 (specifier-type `(and ,type
,slotd-type
)))))))))
1271 :initfunction initfunction
1273 :allocation allocation
1274 :allocation-class allocation-class
1277 :documentation documentation
)))
1279 (defmethod compute-effective-slot-definition-initargs :around
1280 ((class structure-class
) direct-slotds
)
1281 (let* ((slotd (car direct-slotds
))
1282 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1283 (list* :defstruct-accessor-symbol accessor
1284 :internal-reader-function
1285 (slot-definition-internal-reader-function slotd
)
1286 :internal-writer-function
1287 (slot-definition-internal-writer-function slotd
)
1288 (call-next-method))))
1290 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1291 ;;; to make the method object. They have to use make-a-method which
1292 ;;; is a specially bootstrapped mechanism for making standard methods.
1293 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1294 (declare (ignore direct-slot initargs
))
1295 (find-class 'standard-reader-method
))
1297 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1298 (add-method generic-function
1299 (make-a-method 'standard-reader-method
1301 (list (or (class-name class
) 'object
))
1303 (make-reader-method-function class slot-name
)
1304 (or slot-documentation
"automatically generated reader method")
1305 :slot-name slot-name
1307 :method-class-function
#'reader-method-class
1308 :definition-source source-location
)))
1310 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1311 (declare (ignore direct-slot initargs
))
1312 (find-class 'standard-writer-method
))
1314 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1315 (add-method generic-function
1316 (make-a-method 'standard-writer-method
1318 (list 'new-value
(or (class-name class
) 'object
))
1319 (list *the-class-t
* class
)
1320 (make-writer-method-function class slot-name
)
1321 (or slot-documentation
"automatically generated writer method")
1322 :slot-name slot-name
1324 :method-class-function
#'writer-method-class
1325 :definition-source source-location
)))
1327 (defmethod add-boundp-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1328 (add-method generic-function
1329 (make-a-method (constantly (find-class 'standard-boundp-method
))
1332 (list (or (class-name class
) 'object
))
1334 (make-boundp-method-function class slot-name
)
1335 (or slot-documentation
"automatically generated boundp method")
1336 :slot-name slot-name
1337 :definition-source source-location
)))
1339 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1340 (let ((method (get-method generic-function
() (list class
) nil
)))
1341 (when method
(remove-method generic-function method
))))
1343 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1345 (get-method generic-function
() (list *the-class-t
* class
) nil
)))
1346 (when method
(remove-method generic-function method
))))
1348 (defmethod remove-boundp-method ((class slot-class
) generic-function
)
1349 (let ((method (get-method generic-function
() (list class
) nil
)))
1350 (when method
(remove-method generic-function method
))))
1352 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1353 ;;; function are NOT part of the standard protocol. They are however
1354 ;;; useful; PCL makes use of them internally and documents them for
1355 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1357 ;;; *** This needs work to make type testing by the writer functions which
1358 ;;; *** do type testing faster. The idea would be to have one constructor
1359 ;;; *** for each possible type test.
1361 ;;; *** There is a subtle bug here which is going to have to be fixed.
1362 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1363 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1364 ;;; *** defined for this metaclass a chance to run.
1366 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1367 (make-std-reader-method-function class slot-name
))
1369 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1370 (make-std-writer-method-function class slot-name
))
1372 (defmethod make-boundp-method-function ((class slot-class
) slot-name
)
1373 (make-std-boundp-method-function class slot-name
))
1375 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1376 (eq (class-of class
) (class-of proto-new-class
)))
1378 (defmethod validate-superclass ((class class
) (superclass class
))
1379 (or (eq (class-of class
) (class-of superclass
))
1380 (and (eq (class-of superclass
) *the-class-standard-class
*)
1381 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1382 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1383 (eq (class-of class
) *the-class-standard-class
*))))
1385 ;;; What this does depends on which of the four possible values of
1386 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1387 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1388 ;;; nothing to do, as the new wrapper has already been created. If
1389 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1390 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1391 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1393 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1394 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1395 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1396 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1397 ;;; obsolete the wrapper.
1399 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1400 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1401 ;;; :UNINITIALIZED)))
1403 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1404 (defun %force-cache-flushes
(class)
1406 (let* ((owrapper (class-wrapper class
)))
1407 ;; We only need to do something if the wrapper is still valid. If
1408 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1409 ;; both of those will already be doing what we want. In
1410 ;; particular, we must be sure we never change an OBSOLETE into a
1411 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1412 (when (or (not (invalid-wrapper-p owrapper
))
1413 ;; KLUDGE: despite the observations above, this remains
1414 ;; a violation of locality or what might be considered
1415 ;; good style. There has to be a better way! -- CSR,
1417 (eq (layout-invalid owrapper
) t
))
1418 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1420 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1421 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1422 (%update-lisp-class-layout class nwrapper
)
1423 (setf (slot-value class
'wrapper
) nwrapper
)
1424 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1426 (if (find-if (lambda (x)
1427 (and (consp x
) (eq :obsolete
(car x
))))
1428 (layout-inherits owrapper
)
1429 :key
#'layout-invalid
)
1430 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1431 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1434 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1435 ;;; the next access to the instance (as defined in 88-002R) to trap
1436 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1437 (defmethod make-instances-obsolete ((class std-class
))
1439 (let* ((owrapper (class-wrapper class
))
1440 (nwrapper (make-wrapper (layout-length owrapper
)
1442 (unless (class-finalized-p class
)
1443 (if (class-has-a-forward-referenced-superclass-p class
)
1444 (return-from make-instances-obsolete class
)
1445 (%update-cpl class
(compute-class-precedence-list class
))))
1446 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1447 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1448 (%update-lisp-class-layout class nwrapper
)
1449 (setf (slot-value class
'wrapper
) nwrapper
)
1450 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1453 (defmethod make-instances-obsolete ((class symbol
))
1454 (make-instances-obsolete (find-class class
))
1455 ;; ANSI wants the class name when called with a symbol.
1458 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1459 ;;; see an obsolete instance. The times when it is called are:
1460 ;;; - when the instance is involved in method lookup
1461 ;;; - when attempting to access a slot of an instance
1463 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1464 ;;; instance access macros.
1466 ;;; Of course these times when it is called are an internal
1467 ;;; implementation detail of PCL and are not part of the documented
1468 ;;; description of when the obsolete instance update happens. The
1469 ;;; documented description is as it appears in 88-002R.
1471 ;;; This has to return the new wrapper, so it counts on all the
1472 ;;; methods on obsolete-instance-trap-internal to return the new
1473 ;;; wrapper. It also does a little internal error checking to make
1474 ;;; sure that the traps are only happening when they should, and that
1475 ;;; the trap methods are computing appropriate new wrappers.
1477 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1478 ;;; after a structure is redefined. In most cases,
1479 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1480 ;;; so it must signal an error. The hard part of this is that the
1481 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1482 ;;; called again, so in that case, we have to return some reasonable
1483 ;;; wrapper, instead.
1485 (defun %ensure-slot-value-type
(context slot-name slot-type value
1486 old-class new-class
)
1487 (do () ((typep value slot-type
))
1489 (bad-type value slot-type
1490 "~@<Error during ~A. Current value in slot ~
1491 ~/sb-impl::print-symbol-with-prefix/ of an instance ~
1492 of ~S is ~S, which does not match the new slot type ~
1493 ~S in class ~S.~:@>"
1494 context slot-name old-class value slot-type new-class
)
1495 (use-value (new-value)
1496 :interactive read-evaluated-form
1497 :report
(lambda (stream)
1498 (format stream
"~@<Specify a new value to by used ~
1500 ~/sb-impl::print-symbol-with-prefix/ ~
1503 (setf value new-value
))))
1506 (defun %set-slot-value-checking-type
(context slots slot value
1507 safe old-class new-class
)
1508 (setf (clos-slots-ref slots
(slot-definition-location slot
))
1509 (if (and safe
(neq value
+slot-unbound
+))
1510 (let ((name (slot-definition-name slot
))
1511 (type (slot-definition-type slot
)))
1512 (%ensure-slot-value-type context name type value
1513 old-class new-class
))
1516 (defvar *in-obsolete-instance-trap
* nil
)
1518 (define-condition obsolete-structure
(error)
1519 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1521 (lambda (condition stream
)
1522 ;; Don't try to print the structure, since it probably won't work.
1524 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1525 (type-of (obsolete-structure-datum condition
))))))
1527 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1529 ((layout-for-std-class-p owrapper
)
1530 (binding* ((class (wrapper-class* nwrapper
))
1531 (copy (allocate-instance class
)) ;??? allocate-instance ???
1532 (oslots (get-slots instance
))
1533 (nslots (get-slots copy
))
1537 (safe (safe-p class
))
1538 ((new-instance-slots nil new-custom-slots
)
1539 (classify-slotds (layout-slot-list nwrapper
)))
1540 ((old-instance-slots old-class-slots old-custom-slots
)
1541 (classify-slotds (layout-slot-list owrapper
)))
1542 (layout (mapcar (lambda (slotd)
1543 ;; Get the names only once.
1544 (cons (slot-definition-name slotd
) slotd
))
1545 new-instance-slots
)))
1546 ;; local --> local transfer value, check type
1547 ;; local --> shared discard value, discard slot
1548 ;; local --> -- discard slot
1549 ;; local --> custom XXX
1551 ;; shared --> local transfer value, check type
1552 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1553 ;; shared --> -- discard value
1554 ;; shared --> custom XXX
1556 ;; -- --> local add slot
1558 ;; -- --> custom XXX
1559 (flet ((set-value (value cell
)
1560 (%set-slot-value-checking-type
1561 "updating obsolete instance"
1562 nslots
(cdr cell
) value safe class class
)
1563 ;; Prune from the list now that it's been dealt with.
1564 (setf layout
(remove cell layout
))))
1566 ;; Go through all the old local slots.
1567 (dolist (old old-instance-slots
)
1568 (let* ((name (slot-definition-name old
))
1569 (value (clos-slots-ref oslots
(slot-definition-location old
))))
1570 (unless (eq value
+slot-unbound
+)
1571 (let ((new (assq name layout
)))
1573 (set-value value new
))
1575 (push name discarded
)
1576 (setf (getf plist name
) value
)))))))
1578 ;; Go through all the old shared slots.
1579 (dolist (old old-class-slots
)
1580 (binding* ((cell (slot-definition-location old
))
1582 (new (assq name layout
) :exit-if-null
))
1583 (set-value (cdr cell
) new
)))
1585 ;; Go through all custom slots to find added ones. CLHS
1586 ;; doesn't specify what to do about them, and neither does
1587 ;; AMOP. We do want them to get initialized, though, so we
1588 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1589 (dolist (new new-custom-slots
)
1590 (let* ((name (slot-definition-name new
))
1591 (old (find name old-custom-slots
1592 :key
#'slot-definition-name
)))
1594 (push name added
))))
1596 ;; Go through all the remaining new local slots to compute
1598 (dolist (cell layout
)
1599 (push (car cell
) added
)))
1601 (%swap-wrappers-and-slots instance copy
)
1603 (update-instance-for-redefined-class
1604 instance added discarded plist
)
1607 (*in-obsolete-instance-trap
* #.
(find-layout 'structure-object
))
1609 (let ((*in-obsolete-instance-trap
* t
))
1610 (error 'obsolete-structure
:datum instance
)))))
1613 (defun %change-class
(instance new-class initargs
)
1614 (declare (notinline allocate-instance
))
1615 (binding* ((old-class (class-of instance
))
1616 (copy (allocate-instance new-class
))
1617 (new-wrapper (get-wrapper copy
))
1618 (old-wrapper (class-wrapper old-class
))
1619 (old-slots (get-slots instance
))
1620 (new-slots (get-slots copy
))
1621 (safe (safe-p new-class
))
1622 (new-wrapper-slots (layout-slot-list new-wrapper
))
1623 (old-wrapper-slots (layout-slot-list old-wrapper
)))
1624 (labels ((find-instance-slot (name slots
)
1625 (loop for slot in slots
1626 when
(and (eq (slot-definition-allocation slot
) :instance
)
1627 (eq (slot-definition-name slot
) name
))
1629 (initarg-for-slot-p (slot)
1630 (dolist (slot-initarg (slot-definition-initargs slot
))
1631 ;; Abuse +slot-unbound+
1632 (unless (eq +slot-unbound
+
1633 (getf initargs slot-initarg
+slot-unbound
+))
1635 (set-value (value slotd
)
1636 (%set-slot-value-checking-type
1637 'change-class new-slots slotd value safe
1638 old-class new-class
)))
1640 ;; "The values of local slots specified by both the class CTO
1641 ;; and CFROM are retained. If such a local slot was unbound, it
1642 ;; remains unbound."
1643 (dolist (new new-wrapper-slots
)
1644 (when (and (not (initarg-for-slot-p new
))
1645 (eq (slot-definition-allocation new
) :instance
))
1646 (binding* ((old (find-instance-slot (slot-definition-name new
) old-wrapper-slots
)
1648 (value (clos-slots-ref old-slots
(slot-definition-location old
))))
1649 (set-value value new
))))
1651 ;; "The values of slots specified as shared in the class CFROM and
1652 ;; as local in the class CTO are retained."
1653 (dolist (old old-wrapper-slots
)
1654 (when (eq (slot-definition-allocation old
) :class
)
1655 (binding* ((slot-and-val (slot-definition-location old
))
1656 (new (find-instance-slot (car slot-and-val
) new-wrapper-slots
)
1658 (set-value (cdr slot-and-val
) new
)))))
1660 ;; Make the copy point to the old instance's storage, and make the
1661 ;; old instance point to the new storage.
1662 (%swap-wrappers-and-slots instance copy
)
1664 (apply #'update-instance-for-different-class copy instance initargs
)
1668 (defun check-new-class-not-metaobject (new-class)
1669 (dolist (class (class-precedence-list
1670 (ensure-class-finalized new-class
)))
1672 ((check-metaobject (class-name)
1673 `(when (eq class
(find-class ',class-name
))
1674 (change-class-to-metaobject-violation
1675 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1676 (check-metaobject class
)
1677 (check-metaobject generic-function
)
1678 (check-metaobject method
)
1679 (check-metaobject slot-definition
))))
1681 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1684 (check-new-class-not-metaobject new-class
)
1685 (%change-class instance new-class initargs
)))
1687 (defmethod change-class ((instance forward-referenced-class
)
1688 (new-class standard-class
) &rest initargs
)
1690 (dolist (class (class-precedence-list
1691 (ensure-class-finalized new-class
))
1692 (change-class-to-metaobject-violation
1693 '(not class
) 'forward-referenced-class
1694 '((:amop
:generic-function ensure-class-using-class
)
1695 (:amop
:initialization class
))))
1696 (when (eq class
(find-class 'class
))
1698 (%change-class instance new-class initargs
)))
1700 (defmethod change-class ((instance t
)
1701 (new-class forward-referenced-class
) &rest initargs
)
1702 (declare (ignore initargs
))
1703 (change-class-to-metaobject-violation
1704 'forward-referenced-class nil
1705 '((:amop
:generic-function ensure-class-using-class
)
1706 (:amop
:initialization class
))))
1708 (defmethod change-class ((instance funcallable-standard-object
)
1709 (new-class funcallable-standard-class
)
1712 (check-new-class-not-metaobject new-class
)
1713 (%change-class instance new-class initargs
)))
1715 (defmethod change-class ((instance standard-object
)
1716 (new-class funcallable-standard-class
)
1718 (declare (ignore initargs
))
1719 (error "You can't change the class of ~S to ~S~@
1720 because it isn't already an instance with metaclass ~S."
1721 instance new-class
'standard-class
))
1723 (defmethod change-class ((instance funcallable-standard-object
)
1724 (new-class standard-class
)
1726 (declare (ignore initargs
))
1727 (error "You can't change the class of ~S to ~S~@
1728 because it isn't already an instance with metaclass ~S."
1729 instance new-class
'funcallable-standard-class
))
1731 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1732 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1734 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1736 ;;;; These metaclasses are something of a weird creature. By this
1737 ;;;; point, all instances which will exist have been created, and no
1738 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1739 ;;;; distinction between the metaclasses is that we allow subclassing
1740 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1741 ;;;; but not of BUILT-IN-CLASS.)
1743 ;;;; AMOP mandates some behaviour of the implementation with respect
1744 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1745 ;;;; SYSTEM-CLASS here.
1747 (macrolet ((def (name args control
)
1748 `(defmethod ,name
,args
1749 (declare (ignore initargs
))
1750 (error 'metaobject-initialization-violation
1751 :format-control
,(coerce (format nil
"~@<~A~@:>" control
)
1753 :format-arguments
(list (class-name class
))
1754 :references
(list '(:amop
:initialization
"Class"))))))
1755 (def initialize-instance
((class system-class
) &rest initargs
)
1756 "Cannot initialize an instance of ~S.")
1757 (def reinitialize-instance
((class system-class
) &rest initargs
)
1758 "Cannot reinitialize an instance of ~S."))
1760 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1761 (def class-direct-slots
)
1763 (def class-direct-default-initargs
)
1764 (def class-default-initargs
))
1766 (defmethod validate-superclass ((c class
) (s system-class
))
1768 (defmethod validate-superclass ((c class
) (s built-in-class
))
1771 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1772 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1773 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1774 (macrolet ((def (method)
1775 `(defmethod ,method
((class forward-referenced-class
))
1776 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1778 (def class-default-initargs
)
1779 (def class-precedence-list
)
1782 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1785 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1786 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1788 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1789 (setf (plist-value metaobject
'dependents
)
1790 (delete dependent
(plist-value metaobject
'dependents
))))
1792 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1793 (dolist (dependent (plist-value metaobject
'dependents
))
1794 (funcall function dependent
)))