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
))
32 (makunbound (slot-info-makunbound info
)))))
34 (defmethod (setf slot-accessor-function
) (function
35 (slotd effective-slot-definition
)
37 (let ((info (the slot-info
(slot-definition-info slotd
))))
39 (reader (setf (slot-info-reader info
) function
))
40 (writer (setf (slot-info-writer info
) function
))
41 (boundp (setf (slot-info-boundp info
) function
))
42 (makunbound (setf (slot-info-makunbound info
) function
)))))
44 (defconstant +slotd-reader-function-std-p
+ 1)
45 (defconstant +slotd-writer-function-std-p
+ 2)
46 (defconstant +slotd-boundp-function-std-p
+ 4)
47 (defconstant +slotd-makunbound-function-std-p
+ 8)
48 (defconstant +slotd-all-function-std-p
+ 15)
50 (defmethod slot-accessor-std-p ((slotd effective-slot-definition
) type
)
51 (let ((flags (slot-value slotd
'accessor-flags
)))
52 (declare (type fixnum flags
))
54 (eql +slotd-all-function-std-p
+ flags
)
55 (logtest flags
(ecase type
56 (reader +slotd-reader-function-std-p
+)
57 (writer +slotd-writer-function-std-p
+)
58 (boundp +slotd-boundp-function-std-p
+)
59 (makunbound +slotd-makunbound-function-std-p
+))))))
61 (defmethod (setf slot-accessor-std-p
) (value
62 (slotd effective-slot-definition
)
64 (let ((mask (ecase type
65 (reader +slotd-reader-function-std-p
+)
66 (writer +slotd-writer-function-std-p
+)
67 (boundp +slotd-boundp-function-std-p
+)
68 (makunbound +slotd-makunbound-function-std-p
+)))
69 (flags (slot-value slotd
'accessor-flags
)))
70 (declare (type fixnum mask flags
))
71 (setf (slot-value slotd
'accessor-flags
)
72 (logior (logandc2 flags mask
) (if value mask
0))))
75 (defmethod initialize-internal-slot-functions
76 ((slotd effective-slot-definition
))
77 (let* ((name (slot-value slotd
'name
)) ; flushable? (is it ever unbound?)
78 (class (slot-value slotd
'%class
)))
79 (declare (ignore name
))
80 (dolist (type '(reader writer boundp makunbound
))
81 (let* ((gf-name (ecase type
82 (reader 'slot-value-using-class
)
83 (writer '(setf slot-value-using-class
))
84 (boundp 'slot-boundp-using-class
)
85 (makunbound 'slot-makunbound-using-class
)))
86 (gf (gdefinition gf-name
)))
87 ;; KLUDGE: this logic is cut'n'pasted from
88 ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
89 ;; only called later, because it does things that can't be
90 ;; computed this early in class finalization; however, we need
91 ;; this bit as early as possible. -- CSR, 2009-11-05
92 (setf (slot-accessor-std-p slotd type
)
93 (let* ((types1 `((eql ,class
) (class-eq ,class
) (eql ,slotd
)))
94 (types (if (eq type
'writer
) `(t ,@types1
) types1
))
95 (methods (compute-applicable-methods-using-types gf types
)))
96 (null (cdr methods
))))
97 (setf (slot-accessor-function slotd type
)
99 (declare (dynamic-extent args
))
100 ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
101 ;; work here (see KLUDGE comment above).
102 (let ((fun (compute-slot-accessor-info slotd type gf
)))
103 (apply fun args
))))))))
105 (defmethod finalize-internal-slot-functions ((slotd effective-slot-definition
))
106 (dolist (type '(reader writer boundp makunbound
))
107 (let* ((gf-name (ecase type
108 (reader 'slot-value-using-class
)
109 (writer '(setf slot-value-using-class
))
110 (boundp 'slot-boundp-using-class
)
111 (makunbound 'slot-makunbound-using-class
)))
112 (gf (gdefinition gf-name
)))
113 (compute-slot-accessor-info slotd type gf
))))
115 ;;; CMUCL (Gerd PCL 2003-04-25) comment:
117 ;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
118 ;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
119 ;;; writing/testing effective slot SLOTD.
121 ;;; TYPE is one of the symbols READER, WRITER, BOUNDP or MAKUNBOUND,
122 ;;; depending on GF. Store the effective method in the effective slot
123 ;;; definition object itself; these GFs have special dispatch
124 ;;; functions calling effective methods directly retrieved from
125 ;;; effective slot definition objects, as an optimization.
127 ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
129 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition
)
131 (let* ((name (slot-value slotd
'name
)) ; flushable?
132 (class (slot-value slotd
'%class
)))
133 (declare (ignore name
))
134 (multiple-value-bind (function std-p
)
135 (if (eq **boot-state
** 'complete
)
136 (get-accessor-method-function gf type class slotd
)
137 (get-optimized-std-accessor-method-function class slotd type
))
138 (setf (slot-accessor-std-p slotd type
) std-p
)
139 (setf (slot-accessor-function slotd type
) function
))))
141 (defmethod slot-definition-allocation ((slotd structure-slot-definition
))
144 ;;;; various class accessors that are a little more complicated than can be
145 ;;;; done with automatically generated reader methods
147 (defmethod class-prototype :before
((class pcl-class
))
148 (unless (class-finalized-p class
)
149 (error "~@<~S is not finalized.~:@>" class
)))
151 ;;; KLUDGE: For some reason factoring the common body into a function
152 ;;; breaks PCL bootstrapping, so just generate it with a macrolet for
154 (macrolet ((def (class)
155 `(defmethod class-prototype ((class ,class
))
156 (declare (notinline allocate-instance
))
157 (with-slots (prototype) class
159 (setf prototype
(sb-vm:without-arena
"class-prototype"
160 (allocate-instance class
))))))))
162 (def condition-class
)
163 (def structure-class
))
165 (defmethod class-direct-default-initargs ((class slot-class
))
166 (plist-value class
'direct-default-initargs
))
168 (defmethod class-default-initargs ((class slot-class
))
169 (plist-value class
'default-initargs
))
171 (defmethod class-slot-cells ((class std-class
))
172 (plist-value class
'class-slot-cells
))
173 (defmethod (setf class-slot-cells
) (new-value (class std-class
))
174 (setf (plist-value class
'class-slot-cells
) new-value
))
176 ;;;; class accessors that are even a little bit more complicated than those
177 ;;;; above. These have a protocol for updating them, we must implement that
180 ;;; Maintaining the direct subclasses backpointers. The update methods are
181 ;;; here, the values are read by an automatically generated reader method.
182 (defmethod add-direct-subclass ((class class
) (subclass class
))
183 (with-slots (direct-subclasses) class
185 (pushnew subclass direct-subclasses
:test
#'eq
)
186 (let ((layout (class-wrapper subclass
)))
188 (let ((classoid (layout-classoid layout
)))
189 (dovector (super-layout (layout-inherits layout
))
190 (sb-kernel::add-subclassoid
(layout-classoid super-layout
)
191 classoid layout
))))))
193 (defmethod remove-direct-subclass ((class class
) (subclass class
))
194 (with-slots (direct-subclasses) class
196 (setq direct-subclasses
(remove subclass direct-subclasses
))
197 ;; Remove from classoid subclasses as well.
198 (let ((classoid (class-classoid subclass
)))
199 (dovector (super-layout (layout-inherits (classoid-layout classoid
)))
200 (sb-kernel::remove-subclassoid classoid
201 (layout-classoid super-layout
)))))
204 ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
206 ;;; There are four generic functions involved, each has one method. All of
207 ;;; these are specified methods and appear in their specified place in the
210 ;;; ADD-DIRECT-METHOD
211 ;;; REMOVE-DIRECT-METHOD
212 ;;; SPECIALIZER-DIRECT-METHODS
213 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
215 ;;; In each case, we maintain one value which is a cons. The car is the list
216 ;;; of methods. The cdr is a list of the generic functions. The cdr is always
219 ;;; This needs to be used recursively, in case a non-trivial user
220 ;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
221 ;;; function using the same lock.
222 (define-load-time-global *specializer-lock
* (sb-thread:make-mutex
:name
"Specializer lock"))
224 (defmethod add-direct-method :around
((specializer specializer
) (method method
))
225 ;; All the actions done under this lock are done in an order
226 ;; that is safe to unwind at any point.
227 (sb-thread::with-recursive-system-lock
(*specializer-lock
*)
230 (defmethod remove-direct-method :around
((specializer specializer
) (method method
))
231 ;; All the actions done under this lock are done in an order
232 ;; that is safe to unwind at any point.
233 (sb-thread::with-recursive-system-lock
(*specializer-lock
*)
236 (defmethod add-direct-method ((specializer specializer
) (method method
))
237 (let ((cell (specializer-method-holder specializer
)))
238 ;; We need to first smash the CDR, because a parallel read may
239 ;; be in progress, and because if an interrupt catches us we
240 ;; need to have a consistent state.
242 (car cell
) (adjoin method
(car cell
) :test
#'eq
)))
245 (defmethod remove-direct-method ((specializer specializer
) (method method
))
246 (let ((cell (specializer-method-holder specializer
)))
247 ;; We need to first smash the CDR, because a parallel read may
248 ;; be in progress, and because if an interrupt catches us we
249 ;; need to have a consistent state.
251 (car cell
) (remove method
(car cell
))))
254 (defmethod specializer-direct-methods ((specializer specializer
))
255 (car (specializer-method-holder specializer nil
)))
257 (defmethod specializer-direct-generic-functions ((specializer specializer
))
258 (let ((cell (specializer-method-holder specializer nil
)))
259 ;; If an ADD/REMOVE-METHOD is in progress, no matter: either
260 ;; we behave as if we got just first or just after -- it's just
261 ;; for update that we need to lock.
265 (with-system-mutex (*specializer-lock
*)
267 (dolist (m (car cell
) (nreverse collect
))
268 ;; the old PCL code used COLLECTING-ONCE which used
269 ;; #'EQ to check for newness
270 (pushnew (method-generic-function m
) collect
273 (defmethod specializer-method-holder ((self specializer
) &optional create
)
274 ;; CREATE can be ignored, because instances of SPECIALIZER
275 ;; other than CLASS-EQ-SPECIALIZER have their DIRECT-METHODS slot
276 ;; preinitialized with (NIL . NIL).
277 (declare (ignore create
))
278 (slot-value self
'direct-methods
))
280 ;; Same as for CLASS but the only ancestor it shares is SPECIALIZER.
281 ;; If this were defined on SPECIALIZER-WITH-OBJECT then it would
282 ;; apply as well to CLASS-EQ specializers which we don't want.
283 (defmethod specializer-method-holder ((self eql-specializer
) &optional create
)
284 (declare (ignore create
))
285 (slot-value self
'direct-methods
))
287 ;;; This hash table is used to store the direct methods and direct generic
288 ;;; functions of CLASS-EQ specializers.
289 ;;; This is needed because CLASS-EQ specializers are not interned: two different
290 ;;; specializers could refer to the identical CLASS. But semantically you don't
291 ;;; want to collect the direct methods separately, you want them all together.
292 ;;; So a logical place to do that would be in the CLASS. We could add another
293 ;;; slot to CLASS holding the CLASS-EQ-DIRECT-METHODS. I guess the idea though
294 ;;; is to be able to define other kinds of specializers that hold an object
295 ;;; where you don't have the ability to add a slot to that object.
296 ;;; So that's fine, you look up the object in this table, and the approach
297 ;;; generalizes by defining other tables similarly, but has the same problem
298 ;;; of garbage retention as did EQL specializers.
299 ;;; I suspect CLASS-EQ specializers aren't used enough to worry about.
301 ;;; This table is shared between threads, so needs to be synchronized.
302 ;;; (though insertions are only performed when holding the specializer-lock,
303 ;;; so the preceding claim is probably overly paranoid.)
304 (define-load-time-global *class-eq-specializer-methods
*
305 (make-hash-table :test
'eq
:synchronized t
))
307 (defmethod specializer-method-table ((specializer class-eq-specializer
))
308 *class-eq-specializer-methods
*)
310 (defmethod specializer-method-holder ((self specializer-with-object
)
311 &optional
(create t
))
312 (let ((table (specializer-method-table self
))
313 (object (specializer-object self
)))
315 (with-system-mutex ((hash-table-lock table
))
316 (ensure-gethash object table
(cons nil nil
)))
317 ;; FIXME: in the CREATE case we're locking, because we might be inserting,
318 ;; and must ensure mutual exclusion with other writers. Fine,
319 ;; but SBCL's hash-tables aren't *reader* *safe* with any writer, so
320 ;; how can we know that this branch is safe? Honestly I have no idea.
321 ;; I believe that the lock should scope be widened,
322 ;; surrounding either branch of the IF.
323 (gethash object table
))))
325 (defun map-specializers (function)
326 (map-all-classes (lambda (class)
327 (funcall function
(class-eq-specializer class
))
328 (funcall function class
)))
329 (maphash (lambda (object specl
)
330 (declare (ignore object
))
331 (funcall function specl
))
332 *eql-specializer-table
*)
335 (defun map-all-generic-functions (function)
336 (let ((all-generic-functions (make-hash-table :test
'eq
)))
337 (map-specializers (lambda (specl)
338 (dolist (gf (specializer-direct-generic-functions
340 (unless (gethash gf all-generic-functions
)
341 (setf (gethash gf all-generic-functions
) t
)
342 (funcall function gf
))))))
345 (defmethod shared-initialize :after
((specl class-eq-specializer
)
348 (declare (ignore slot-names
))
349 (setf (slot-value specl
'%type
) `(class-eq ,(specializer-class specl
))))
351 (defmethod shared-initialize :after
((specl eql-specializer
) slot-names
&key
)
352 (declare (ignore slot-names
))
353 (setf (slot-value specl
'%type
)
354 `(eql ,(specializer-object specl
))))
356 (defun real-load-defclass (name metaclass-name supers slots other
357 readers writers slot-names source-location
&optional safe-p
)
358 (sb-kernel::call-with-defining-class
361 (sb-kernel::%%compiler-defclass name readers writers slot-names
)
362 (apply #'ensure-class name
:metaclass metaclass-name
363 :direct-superclasses supers
365 'source source-location
369 (setf (gdefinition 'load-defclass
) #'real-load-defclass
)
371 (defun ensure-class (name &rest args
)
373 (apply #'ensure-class-using-class
374 (let ((class (find-class name nil
)))
375 (when (and class
(eq name
(class-name class
)))
376 ;; NAME is the proper name of CLASS, so redefine it
380 (defun parse-ensure-class-args (class name args
)
381 (let ((metaclass *the-class-standard-class
*)
383 (reversed-plist '()))
384 (labels ((find-class* (which class-or-name
)
386 ((classp class-or-name
)
388 ((eq class-or-name class
)
389 (error "~@<Class ~A specified as its own ~
391 class-or-name which
))
394 ((and class-or-name
(legal-class-name-p class-or-name
))
396 ((eq class-or-name name
)
397 (error "~@<Class named ~
398 ~/sb-ext:print-symbol-with-prefix/ ~
399 specified as its own ~(~A~)class.~@:>"
400 class-or-name which
))
401 ((find-class class-or-name
(eq which
:meta
)))
403 class-or-name
:metaclass
'forward-referenced-class
))))
405 (error "~@<Not a class or a legal ~(~A~)class name: ~
407 which class-or-name
))))
408 (find-superclass (class-or-name)
409 (find-class* :super class-or-name
)))
410 (doplist (key value
) args
414 (setf metaclass
(find-class* :meta value
)
416 (:direct-superclasses
417 (let ((superclasses (mapcar #'find-superclass value
)))
418 (setf reversed-plist
(list* superclasses key reversed-plist
))))
420 (setf reversed-plist
(list* value key reversed-plist
)))))
421 (values metaclass
(nreverse reversed-plist
)))))
423 (defun call-with-ensure-class-context (class name args thunk
)
424 (let ((class (with-world-lock ()
425 (multiple-value-bind (metaclass initargs
)
426 (parse-ensure-class-args class name args
)
427 (let ((class (funcall thunk class name metaclass initargs
)))
428 (without-package-locks
429 (setf (find-class name
) class
)))))))
432 (defmethod ensure-class-using-class ((class null
) name
&rest args
&key
)
433 (call-with-ensure-class-context
434 class name args
(lambda (class name metaclass initargs
)
435 (declare (ignore class
))
436 (apply #'make-instance metaclass
:name name initargs
))))
438 (defmethod ensure-class-using-class ((class pcl-class
) name
&rest args
&key
)
439 (call-with-ensure-class-context
440 class name args
(lambda (class name metaclass initargs
)
441 (aver (eq name
(class-name class
)))
442 (unless (eq (class-of class
) metaclass
)
443 (apply #'change-class class metaclass initargs
))
444 (apply #'reinitialize-instance class initargs
)
447 ;;; This is used to call initfunctions of :allocation :class slots.
448 (defun call-initfun (fun slotd safe
)
449 (declare (function fun
))
450 (let ((value (funcall fun
)))
452 (let ((type (slot-definition-type slotd
)))
453 (unless (or (eq t type
)
455 (error 'type-error
:expected-type type
:datum value
))))
458 (defmethod shared-initialize :after
459 ((class std-class
) slot-names
&key
460 (direct-superclasses nil direct-superclasses-p
)
461 (direct-slots nil direct-slots-p
)
462 (direct-default-initargs nil direct-default-initargs-p
))
463 (cond (direct-superclasses-p
464 (setq direct-superclasses
465 (or direct-superclasses
466 (list (if (funcallable-standard-class-p class
)
467 *the-class-funcallable-standard-object
*
468 *the-class-standard-object
*))))
469 (dolist (superclass direct-superclasses
)
470 (unless (validate-superclass class superclass
)
471 (invalid-superclass class superclass
)))
472 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
474 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
477 (setf (slot-value class
'direct-slots
)
478 (mapcar (lambda (pl) (make-direct-slotd class pl
))
480 (slot-value class
'direct-slots
)))
481 (when direct-default-initargs-p
482 (setf (plist-value class
'direct-default-initargs
) direct-default-initargs
))
483 (setf (plist-value class
'class-slot-cells
)
484 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
485 (safe (safe-p class
))
487 (dolist (dslotd direct-slots
)
488 (when (eq :class
(slot-definition-allocation dslotd
))
490 (let* ((name (slot-definition-name dslotd
))
491 (old (assoc name old-class-slot-cells
)))
494 (member name slot-names
:test
#'eq
))
495 (let* ((initfunction (slot-definition-initfunction dslotd
))
498 (call-initfun initfunction dslotd safe
)
500 (push (cons name value
) collect
))
501 (push old collect
)))))
503 (add-direct-subclasses class direct-superclasses
)
504 (if (class-finalized-p class
)
505 ;; required by AMOP, "Reinitialization of Class Metaobjects"
506 (finalize-inheritance class
)
507 (update-class class nil
))
508 (add-slot-accessors class direct-slots
)
509 (make-preliminary-layout class
))
511 (define-condition invalid-superclass
(reference-condition error
)
512 ((class :initarg
:class
:reader invalid-superclass-class
)
513 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
516 (let ((class (invalid-superclass-class c
))
517 (superclass (invalid-superclass-superclass c
)))
519 "~@<The class ~S was specified as a superclass of the ~
520 class ~S, but the metaclasses ~S and ~S are ~
521 incompatible.~@[ Define a method for ~S to avoid this ~
523 superclass class
(class-of superclass
) (class-of class
)
524 (and (typep superclass
'standard-class
)
525 'validate-superclass
))))))
527 (defmethod invalid-superclass ((class class
) (superclass class
))
528 (error 'invalid-superclass
:class class
:superclass superclass
529 :references
`((:amop
:generic-function validate-superclass
)
530 ,@(when (typep superclass
'built-in-class
)
531 '((:ansi-cl
:system-class built-in-class
)
532 (:ansi-cl
:section
(4 3 7)))))))
534 (defmethod shared-initialize :after
((class forward-referenced-class
)
535 slot-names
&key
&allow-other-keys
)
536 (declare (ignore slot-names
))
537 (make-preliminary-layout class
))
539 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
541 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
542 ;;; make it known to the type system.
543 (defun make-preliminary-layout (class)
544 (flet ((compute-preliminary-cpl (root)
545 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
546 (compute-class-precedence-list root
))))
548 (without-package-locks
549 (unless (class-finalized-p class
)
550 (let ((name (class-name class
))) ; flushable?
551 (declare (ignore name
))
552 ;; KLUDGE: This is fairly horrible. We need to make a
553 ;; full-fledged CLASSOID here, not just tell the compiler that
554 ;; some class is forthcoming, because there are legitimate
555 ;; questions one can ask of the type system, implemented in
556 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
557 (let ((wrapper (make-wrapper 0 class
)))
558 (setf (slot-value class
'wrapper
) wrapper
)
559 (let ((cpl (compute-preliminary-cpl class
)))
560 (set-layout-inherits wrapper
561 (order-layout-inherits
562 (map 'simple-vector
#'class-wrapper
563 (reverse (rest cpl
))))
565 (set-bitmap-and-flags wrapper
)
566 (register-layout wrapper
:invalidate t
))))
567 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
570 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
571 (declare (ignore slot-names name
))
572 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
573 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
574 (setf (slot-value class
'%type
) `(class ,class
))
575 (setf (slot-value class
'class-eq-specializer
)
576 (make-instance 'class-eq-specializer
:class class
)))
578 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
579 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
580 (remove-direct-subclass old-super class
))
581 (remove-slot-accessors class
(class-direct-slots class
)))
583 (defmethod reinitialize-instance :after
((class slot-class
)
586 (map-dependents class
588 (apply #'update-dependent class dependent initargs
))))
590 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
591 (let* ((name (class-name class
))
592 (classoid (find-classoid name
))
593 (slots (condition-classoid-slots classoid
))
594 (source (sb-kernel::classoid-source-location classoid
)))
595 ;; to balance the REMOVE-SLOT-ACCESSORS call in
596 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
597 (flet ((add-source-location (method)
599 (setf (slot-value method
'source
) source
))))
601 (let ((slot-name (condition-slot-name slot
)))
602 (dolist (reader (condition-slot-readers slot
))
603 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
604 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
606 (sb-kernel::install-condition-slot-reader reader name slot-name
)))
607 (dolist (writer (condition-slot-writers slot
))
609 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))))
611 (defmethod shared-initialize :after
((class condition-class
) slot-names
612 &key direct-slots direct-superclasses
)
613 (declare (ignore slot-names
))
614 (let ((classoid (find-classoid (slot-value class
'name
))))
616 %class-precedence-list cpl-available-p finalized-p
617 prototype
(direct-supers direct-superclasses
)
620 (setf (slot-value class
'direct-slots
)
621 (mapcar (lambda (pl) (make-direct-slotd class pl
))
624 (classoid-pcl-class classoid
) class
625 direct-supers direct-superclasses
626 wrapper
(classoid-layout classoid
)
627 %class-precedence-list
(compute-class-precedence-list class
)
629 (getf plist
'direct-default-initargs
)
630 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
631 (add-direct-subclasses class direct-superclasses
)
632 (let ((slots (compute-slots class
)))
633 (setf (slot-value class
'slots
) slots
)
634 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
635 ;; Comment from Gerd's PCL, 2003-05-15:
637 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
638 ;; override condition accessors with generic functions. We do this
641 ;; ??? What does the above comment mean and why is it a good idea?
642 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
643 ;; comment) loses slot information in its condition classes:
644 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
645 ;; remove slot accessors but never put them back. I've added a
646 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
647 ;; was meant to happen? -- CSR, 2005-11-18
650 (defmethod direct-slot-definition-class ((class condition-class
)
652 (declare (ignore initargs
))
653 (find-class 'condition-direct-slot-definition
))
655 (defmethod effective-slot-definition-class ((class condition-class
)
657 (declare (ignore initargs
))
658 (find-class 'condition-effective-slot-definition
))
660 (defmethod finalize-inheritance ((class condition-class
))
661 (aver (slot-value class
'finalized-p
))
664 (defmethod compute-effective-slot-definition
665 ((class condition-class
) slot-name dslotds
)
666 (let* ((slotd (call-next-method))
667 (info (slot-definition-info slotd
)))
668 (setf (slot-info-reader info
)
670 (handler-case (condition-slot-value x slot-name
)
671 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
672 ;; is unbound; maybe it should be a CELL-ERROR of some
674 (error () (values (slot-unbound class x slot-name
))))))
675 (setf (slot-info-writer info
)
677 (set-condition-slot-value x v slot-name
)))
678 (setf (slot-info-boundp info
)
680 (condition-slot-boundp x slot-name
)))
681 (setf (slot-info-makunbound info
)
683 (condition-slot-makunbound x slot-name
)))
686 (defmethod compute-slots :around
((class condition-class
))
687 (let ((eslotds (call-next-method)))
688 (mapc #'finalize-internal-slot-functions eslotds
)
691 (defmethod shared-initialize :after
692 ((slotd structure-slot-definition
) slot-names
&key
693 (allocation :instance
) allocation-class
)
694 (declare (ignore slot-names allocation-class
))
695 (unless (eq allocation
:instance
)
696 (error "Structure slots must have :INSTANCE allocation.")))
698 (defun make-structure-class-defstruct-form (name direct-slots include
)
699 (let* ((conc-name (pkg-format-symbol *package
* "~S structure class " name
))
700 (constructor (pkg-format-symbol *package
* "~Aconstructor" conc-name
))
701 (included-name (class-name include
))
704 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
709 (dolist (slotd (reverse direct-slots
))
710 (let* ((slot-name (slot-definition-name slotd
))
711 (initform (slot-definition-initform slotd
))
712 (type (slot-definition-type slotd
))
713 (desc `(,slot-name
,initform
:type
,type
)))
714 (push `(slot-accessor ,name
,slot-name reader
)
716 (push `(slot-accessor ,name
,slot-name writer
)
718 (if (member slot-name included-slots
:test
#'eq
)
719 (push desc old-slots
)
720 (push desc new-slots
))))
721 (let* ((defstruct `(defstruct (,name
723 `((:include
,included-name
725 (:constructor
,constructor
())
727 (:conc-name
,conc-name
)
731 (mapcar (lambda (slotd reader-name
)
733 (slot-definition-defstruct-accessor-symbol
735 `(defun ,reader-name
(obj)
736 (declare (type ,name obj
))
738 direct-slots reader-names
))
740 (mapcar (lambda (slotd writer-name
)
742 (slot-definition-defstruct-accessor-symbol
744 `(defun ,writer-name
(nv obj
)
745 (declare (type ,name obj
))
746 (setf (,accessor obj
) nv
))))
747 direct-slots writer-names
))
751 ,@readers-init
,@writers-init
753 (values defstruct-form constructor reader-names writer-names
))))
755 ;;; Return a thunk to allocate an instance of CLASS named NAME.
756 ;;; This is broken with regard to the expectation that all semantic
757 ;;; processing is done by the compiler. e.g. after COMPILE-FILE on
758 ;;; a file containing these two toplevel forms:
759 ;;; (eval-when (:compile-toplevel) (defmacro maker () '(list 1)))
760 ;;; (defstruct foo (a (maker)))
761 ;;; then LOADing the resulting fasl in a fresh image will err:
762 ;;; (make-instance 'foo) => "The function MAKER is undefined."
764 ;;; The way to fix that is to ensure that every defstruct has a zero-argument
765 ;;; constructor made by the compiler and stashed in a random symbol.
766 (defun make-defstruct-allocation-function (name class
)
767 (declare (muffle-conditions code-deletion-note
))
768 ;; FIXME: Why don't we go class->layout->info == dd
769 (let ((dd (find-defstruct-description name
)))
772 ;; This used to call COMPILE directly, which is basically pointless,
773 ;; because it certainly does not avoid compiling code at runtime,
774 ;; which seems to have been the goal. We're also compiling:
775 ;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #<STRUCTURE-CLASS THING>))
776 ;; So maybe we can figure out how to bundle two lambdas together?
778 (let* ((dd (layout-dd (class-wrapper class
)))
779 (f (%make-structure-instance-allocator dd nil nil
)))
781 (funcall (setf (slot-value class
'defstruct-constructor
) f
))
782 (error "Can't allocate ~S" class
)))))
783 (funcallable-structure
784 ;; FIXME: you can't dynamically define new funcallable structures
785 ;; that are not GENERIC-FUNCTION subtypes, so why this branch?
786 ;; We should pull this out, fixup PCL bootstrap, and not pretend
787 ;; that this code is more general than it really is.
788 (%make-funcallable-structure-instance-allocator dd nil
)))))
790 (defmethod shared-initialize :after
791 ((class structure-class
) slot-names
&key
792 (direct-superclasses nil direct-superclasses-p
)
793 (direct-slots nil direct-slots-p
)
794 direct-default-initargs
)
795 (declare (ignore slot-names direct-default-initargs
))
796 (if direct-superclasses-p
797 (setf (slot-value class
'direct-superclasses
)
798 (or direct-superclasses
799 (setq direct-superclasses
800 (and (not (eq (slot-value class
'name
) 'structure-object
))
801 (list *the-class-structure-object
*)))))
802 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
803 (let* ((name (slot-value class
'name
))
804 (from-defclass-p (slot-value class
'from-defclass-p
))
805 ;; DEFSTRUCT-P means we should perform the effect of DEFSTRUCT,
806 ;; and not that this structure came from a DEFSTRUCT.
807 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
809 (setf (slot-value class
'direct-slots
)
813 (let* ((slot-name (getf pl
:name
))
815 (pkg-format-symbol *package
*
816 "~S structure class ~A"
818 (setq pl
(list* :defstruct-accessor-symbol
820 (make-direct-slotd class pl
))
822 (setq direct-slots
(slot-value class
'direct-slots
)))
824 (let ((include (car (slot-value class
'direct-superclasses
))))
825 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
826 (make-structure-class-defstruct-form name direct-slots include
)
827 (unless (structure-type-p name
) (eval defstruct-form
))
828 (mapc (lambda (dslotd reader-name writer-name
)
829 (let* ((reader (gdefinition reader-name
))
830 (writer (when (fboundp writer-name
)
831 (gdefinition writer-name
))))
832 (setf (slot-value dslotd
'internal-reader-function
)
834 (setf (slot-value dslotd
'internal-writer-function
)
836 direct-slots reader-names writer-names
)
837 (setf (slot-value class
'defstruct-form
) defstruct-form
)
838 (setf (slot-value class
'defstruct-constructor
) constructor
)))
839 ;; FIXME: If we always need a default constructor, then why not just make
840 ;; a "hidden" one at actual-compile-time and store it?
841 ;; And this is very broken with regard to the lexical environment.
842 ;; And why isn't this just DD-DEFAULT-CONSTRUCTOR if there was one?
843 (setf (slot-value class
'defstruct-constructor
)
844 ;; KLUDGE: not class; in fixup.lisp, can't access slots
845 ;; outside methods yet.
846 (make-defstruct-allocation-function name class
)))
847 (add-direct-subclasses class direct-superclasses
)
848 (setf (slot-value class
'%class-precedence-list
)
849 (compute-class-precedence-list class
))
850 (setf (slot-value class
'cpl-available-p
) t
)
851 (let ((slots (compute-slots class
)))
852 (setf (slot-value class
'slots
) slots
)
853 (let* ((lclass (find-classoid (slot-value class
'name
)))
854 (layout (classoid-layout lclass
)))
855 (setf (classoid-pcl-class lclass
) class
)
856 (setf (slot-value class
'wrapper
) layout
)
857 (setf (sb-kernel::layout-slot-mapper layout
)
858 (sb-kernel::make-struct-slot-map
(layout-dd layout
)))
859 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
860 (setf (slot-value class
'finalized-p
) t
)
861 (add-slot-accessors class direct-slots
)))
863 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
864 (declare (ignore initargs
))
865 (find-class 'structure-direct-slot-definition
))
867 (defmethod finalize-inheritance ((class structure-class
))
868 nil
) ; always finalized
870 (defun add-slot-accessors (class dslotds
)
871 (fix-slot-accessors class dslotds
'add
))
873 (defun remove-slot-accessors (class dslotds
)
874 (fix-slot-accessors class dslotds
'remove
))
876 (defun fix-slot-accessors (class dslotds add
/remove
)
877 (flet ((fix (gfspec name r
/w doc source-location
)
878 (let ((gf (cond ((eq add
/remove
'add
)
879 (or (find-generic-function gfspec nil
)
880 (ensure-generic-function
881 gfspec
:lambda-list
(case r
/w
883 (w '(new-value object
))))))
885 (find-generic-function gfspec nil
)))))
888 (r (if (eq add
/remove
'add
)
889 (add-reader-method class gf name doc source-location
)
890 (remove-reader-method class gf
)))
891 (w (if (eq add
/remove
'add
)
892 (add-writer-method class gf name doc source-location
)
893 (remove-writer-method class gf
))))))))
894 (dolist (dslotd dslotds
)
895 (let ((slot-name (slot-definition-name dslotd
))
896 (slot-doc (%slot-definition-documentation dslotd
))
897 (location (definition-source dslotd
)))
898 (dolist (r (slot-definition-readers dslotd
))
899 (fix r slot-name
'r slot-doc location
))
900 (dolist (w (slot-definition-writers dslotd
))
901 (fix w slot-name
'w slot-doc location
))))))
903 (defun add-direct-subclasses (class supers
)
904 (dolist (super supers
)
905 (unless (memq class
(class-direct-subclasses class
))
906 (add-direct-subclass super class
))))
908 (defmethod finalize-inheritance ((class std-class
))
909 (update-class class t
))
911 (defmethod finalize-inheritance ((class forward-referenced-class
))
912 ;; FIXME: should we not be thinking a bit about what kinds of error
913 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
914 ;; possibly a forward-referenced-class-error, though that's
915 ;; difficult given e.g. class precedence list calculations...
917 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
922 (defun class-has-a-forward-referenced-superclass-p (class)
923 (or (when (forward-referenced-class-p class
)
925 (some #'class-has-a-forward-referenced-superclass-p
926 (class-direct-superclasses class
))))
928 ;;; This is called by :after shared-initialize whenever a class is initialized
929 ;;; or reinitialized. The class may or may not be finalized.
930 (defun update-class (class finalizep
)
931 (labels ((rec (class finalizep
&optional
(seen '()))
932 (when (find class seen
:test
#'eq
)
933 (error "~@<Specified class ~S as a superclass of ~
936 (without-package-locks
938 (when (or finalizep
(class-finalized-p class
))
939 (%update-cpl class
(compute-class-precedence-list class
))
940 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
942 (%update-slots class
(compute-slots class
))
943 (update-gfs-of-class class
)
944 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
945 (update-ctors 'finalize-inheritance
:class class
))
946 (let ((seen (list* class seen
)))
947 (dolist (sub (class-direct-subclasses class
))
948 (rec sub nil seen
)))))))
949 (rec class finalizep
)))
951 (define-condition cpl-protocol-violation
(reference-condition error
)
952 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
953 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
954 (:default-initargs
:references
'((:sbcl
:node
"Metaobject Protocol")))
957 (format s
"~@<Protocol violation: the ~S class ~S ~
958 ~:[has~;does not have~] the class ~S in its ~
959 class precedence list: ~S.~@:>"
960 (class-name (class-of (cpl-protocol-violation-class c
)))
961 (cpl-protocol-violation-class c
)
962 (eq (class-of (cpl-protocol-violation-class c
))
963 *the-class-funcallable-standard-class
*)
964 (find-class 'function
)
965 (cpl-protocol-violation-cpl c
)))))
967 (defun class-has-a-cpl-protocol-violation-p (class)
968 (labels ((find-in-superclasses (class classes
)
971 ((eql class
(car classes
)) t
)
972 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
973 (let ((metaclass (class-of class
)))
975 ((eql metaclass
*the-class-standard-class
*)
976 (find-in-superclasses (find-class 'function
) (list class
)))
977 ((eql metaclass
*the-class-funcallable-standard-class
*)
978 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
980 (defun %update-cpl
(class cpl
)
982 (eq (class-of class
) *the-class-standard-class
*)
983 (find *the-class-function
* cpl
))
984 (and (eq (class-of class
) *the-class-funcallable-standard-class
*)
985 (not (and (find (find-class 'function
) cpl
)))))
986 (error 'cpl-protocol-violation
:class class
:cpl cpl
))
987 (cond ((not (class-finalized-p class
))
988 (setf (slot-value class
'%class-precedence-list
) cpl
989 (slot-value class
'cpl-available-p
) t
))
990 ((not (and (equal (class-precedence-list class
) cpl
)
992 (when (position :class
(class-direct-slots c
)
993 :key
#'slot-definition-allocation
)
996 ;; comment from the old CMU CL sources:
997 ;; Need to have the cpl setup before %update-lisp-class-layout
998 ;; is called on CMU CL.
999 (setf (slot-value class
'%class-precedence-list
) cpl
1000 (slot-value class
'cpl-available-p
) t
)
1001 (%force-cache-flushes class
)))
1002 (update-class-can-precede-p cpl
))
1004 (defun update-class-can-precede-p (cpl)
1006 (let ((first (car cpl
)))
1007 (dolist (c (cdr cpl
))
1008 ;; This is (PUSHNEW c (SLOT-VALUE FIRST 'can-precede-list) :TEST #'EQ)))
1009 ;; but avoids consing in an arena. Perhaps the ADJOIN transform could sense
1010 ;; whether to change %ADJOIN-EQ to SYS-TLAB-ADJOIN-EQ ?
1011 (with-slots (can-precede-list) first
1012 (setf can-precede-list
(sys-tlab-adjoin-eq c can-precede-list
)))))
1013 (update-class-can-precede-p (cdr cpl
))))
1015 (defun class-can-precede-p (class1 class2
)
1016 (member class2
(class-can-precede-list class1
) :test
#'eq
))
1018 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
1020 ;;; In addition to slot locations (implicit in the ordering of the slots), we
1021 ;;; must check classes: SLOT-INFO structures from old slotds may have been
1022 ;;; cached in permutation vectors, but new slotds have had new ones allocated
1023 ;;; to them. This is non-problematic for standard slotds, because we know the
1024 ;;; structure is compatible, but if a slot definition class changes, this can
1025 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
1027 ;;; Also, if the slot has a non-standard allocation, we need to check that it
1029 (defun slot-layouts-compatible-p
1030 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
1031 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
1032 (classify-slotds oslotds
)
1034 ;; Instance slots: name, type, and class.
1035 (dolist (o old-instance-slotds
(not new-instance-slotds
))
1036 (let ((n (pop new-instance-slotds
)))
1038 (eq (slot-definition-name o
) (slot-definition-name n
))
1039 (eq (slot-definition-type o
) (slot-definition-type n
))
1040 (eq (class-of o
) (class-of n
)))
1042 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
1043 (dolist (o old-class-slotds
(not new-class-slotds
))
1044 (let ((n (pop new-class-slotds
)))
1046 (eq (slot-definition-name o
) (slot-definition-name n
))
1047 (eq (class-of n
) (class-of o
)))
1049 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
1050 (dolist (o old-custom-slotds
(not new-custom-slotds
))
1051 (let ((n (pop new-custom-slotds
)))
1053 (eq (slot-definition-name o
) (slot-definition-name n
))
1054 (eq (slot-definition-type o
) (slot-definition-type n
))
1055 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1056 (eq (class-of o
) (class-of n
)))
1059 (defun style-warn-about-duplicate-slots (class)
1060 (flet ((symbol-exported-p (symbol)
1061 (let ((packages (list-all-packages))
1062 (name (symbol-name symbol
)))
1063 (dolist (package packages nil
)
1064 (multiple-value-bind (s status
) (find-symbol name package
)
1065 (when (and (eq s symbol
) (eq status
:external
))
1067 (do* ((dslots (class-direct-slots class
) (cdr dslots
))
1068 (slots (slot-value class
'slots
))
1073 "~@<slot names with the same SYMBOL-NAME but ~
1074 different SYMBOL-PACKAGE (possible package problem) ~
1075 for class ~S:~4I~@:_~<~@{~/sb-ext:print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1077 (let* ((slot-name (slot-definition-name (car dslots
)))
1079 (lambda (slot-name-2)
1080 (or (eq slot-name slot-name-2
)
1081 (string/= slot-name slot-name-2
)
1082 (not (symbol-exported-p slot-name-2
))))
1084 :key
#'slot-definition-name
)))
1086 (pushnew (cons slot-name
(mapcar #'slot-definition-name oslots
)) dupes
1087 :test
#'string
= :key
#'car
))))))
1089 (defun %update-slots
(class eslotds
)
1090 (multiple-value-bind (instance-slots class-slots custom-slots
)
1091 (classify-slotds eslotds
)
1092 (let* ((nslots (length instance-slots
))
1093 (owrapper (class-wrapper class
))
1095 (cond ((and owrapper
1096 (slot-layouts-compatible-p (wrapper-slot-list owrapper
)
1097 instance-slots class-slots custom-slots
))
1100 (not (class-finalized-p class
)))
1101 (make-wrapper nslots class
))
1103 ;; This will initialize the new wrapper to have the
1104 ;; same state as the old wrapper. We will then have
1105 ;; to change that. This may seem like wasted work
1106 ;; (and it is), but the spec requires that we call
1107 ;; MAKE-INSTANCES-OBSOLETE.
1108 (make-instances-obsolete class
)
1109 (class-wrapper class
)))))
1110 (%update-lisp-class-layout class nwrapper
)
1111 (setf (slot-value class
'slots
) eslotds
1112 (wrapper-slot-list nwrapper
) eslotds
1113 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1114 (layout-length nwrapper
) nslots
1115 (slot-value class
'wrapper
) nwrapper
)
1116 (style-warn-about-duplicate-slots class
)
1117 (setf (slot-value class
'finalized-p
) t
))))
1119 (defun update-gf-dfun (class gf
)
1120 (let ((*new-class
* class
)
1121 (arg-info (gf-arg-info gf
)))
1123 ((special-case-for-compute-discriminating-function-p gf
))
1124 ((gf-precompute-dfun-and-emf-p arg-info
)
1125 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1126 (update-dfun gf dfun cache info
))))))
1128 (defun update-gfs-of-class (class)
1129 (when (and (class-finalized-p class
)
1130 (let ((cpl (class-precedence-list class
)))
1131 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1132 (member *the-class-standard-effective-slot-definition
*
1134 (let ((gf-table (make-hash-table :test
'eq
)))
1135 (labels ((collect-gfs (class)
1136 (dolist (gf (specializer-direct-generic-functions class
))
1137 (setf (gethash gf gf-table
) t
))
1138 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1140 (maphash (lambda (gf ignore
)
1141 (declare (ignore ignore
))
1142 (update-gf-dfun class gf
))
1145 (defmethod compute-default-initargs ((class slot-class
))
1146 (let ((initargs (loop for c in
(class-precedence-list class
)
1147 append
(class-direct-default-initargs c
))))
1148 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1150 ;;;; protocols for constructing direct and effective slot definitions
1152 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1153 (declare (ignore initargs
))
1154 (find-class 'standard-direct-slot-definition
))
1156 (defun make-direct-slotd (class initargs
)
1157 (apply #'make-instance
1158 (apply #'direct-slot-definition-class class initargs
)
1162 ;;; I (CSR) am not sure, but I believe that the particular order of
1163 ;;; slots is quite important: it is ideal to attempt to have a
1164 ;;; constant slot location for the same notional slots as much as
1165 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1166 ;;; al.) have a chance of working. The below at least walks through
1167 ;;; the slots predictably, but maybe it would be good to compute some
1168 ;;; kind of optimal slot layout by looking at locations of slots in
1170 (defun std-compute-slots (class)
1171 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1172 ;; for each different slot name we find in our superclasses. Each
1173 ;; call receives the class and a list of the dslotds with that name.
1174 ;; The list is in most-specific-first order.
1175 (let ((name-dslotds-alist ()))
1176 (dolist (c (reverse (class-precedence-list class
)))
1177 (dolist (slot (class-direct-slots c
))
1178 (let* ((name (slot-definition-name slot
))
1179 (entry (assq name name-dslotds-alist
)))
1181 (push slot
(cdr entry
))
1182 (push (list name slot
) name-dslotds-alist
)))))
1183 (mapcar (lambda (direct)
1184 (compute-effective-slot-definition class
1187 (nreverse name-dslotds-alist
))))
1189 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1190 (defmethod compute-slots ((class standard-class
))
1191 (std-compute-slots class
))
1192 (defmethod compute-slots ((class funcallable-standard-class
))
1193 (std-compute-slots class
))
1194 (defmethod compute-slots ((class structure-class
))
1195 (std-compute-slots class
))
1196 (defmethod compute-slots ((class condition-class
))
1197 (std-compute-slots class
))
1199 (defun std-compute-slots-around (class eslotds
)
1201 (safe (safe-p class
)))
1202 (dolist (eslotd eslotds eslotds
)
1203 (setf (slot-definition-location eslotd
)
1204 (case (slot-definition-allocation eslotd
)
1208 (let* ((name (slot-definition-name eslotd
))
1211 (slot-definition-allocation-class eslotd
)
1212 ;; we get here if the user adds an extra slot
1214 (setf (slot-definition-allocation-class eslotd
)
1216 ;; which raises the question of what we should
1217 ;; do if we find that said user has added a slot
1218 ;; with the same name as another slot...
1219 (cell (or (assq name
(class-slot-cells from-class
))
1220 (let ((c (cons name
+slot-unbound
+)))
1221 (push c
(class-slot-cells from-class
))
1224 (if (unbound-marker-p (cdr cell
))
1225 ;; We may have inherited an initfunction FIXME: Is this
1226 ;; really right? Is the initialization in
1227 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1228 (let ((initfun (slot-definition-initfunction eslotd
)))
1230 (rplacd cell
(call-initfun initfun eslotd safe
))
1233 (unless (slot-definition-class eslotd
)
1234 (setf (slot-definition-class eslotd
) class
))
1235 (let ((info (slot-definition-info eslotd
)))
1236 (setf (slot-info-allocation info
) (slot-definition-allocation eslotd
)
1237 (slot-info-location info
) (slot-definition-location eslotd
)))
1238 (initialize-internal-slot-functions eslotd
))))
1240 (defmethod compute-slots :around
((class standard-class
))
1241 (let ((eslotds (call-next-method)))
1242 (std-compute-slots-around class eslotds
)))
1243 (defmethod compute-slots :around
((class funcallable-standard-class
))
1244 (let ((eslotds (call-next-method)))
1245 (std-compute-slots-around class eslotds
)))
1246 (defmethod compute-slots :around
((class structure-class
))
1247 (let ((eslotds (call-next-method)))
1248 (mapc #'finalize-internal-slot-functions eslotds
)
1251 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1252 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1253 (class (apply #'effective-slot-definition-class class initargs
))
1254 (slotd (apply #'make-instance class initargs
)))
1257 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1258 (declare (ignore initargs
))
1259 (find-class 'standard-effective-slot-definition
))
1261 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1262 (declare (ignore initargs
))
1263 (find-class 'structure-effective-slot-definition
))
1265 (defmethod compute-effective-slot-definition-initargs
1266 ((class slot-class
) direct-slotds
)
1272 (allocation-class nil
)
1275 (documentationp nil
)
1280 (dolist (slotd direct-slotds
)
1283 (setq name
(slot-definition-name slotd
)
1286 (awhen (slot-definition-initfunction slotd
)
1287 (setq initform
(slot-definition-initform slotd
)
1290 (unless documentationp
1291 (awhen (%slot-definition-documentation slotd
)
1292 (setq documentation it
1295 (setq allocation
(slot-definition-allocation slotd
)
1296 allocation-class
(slot-definition-class slotd
)
1298 (setq initargs
(union (slot-definition-initargs slotd
) initargs
))
1299 (let ((slotd-type (slot-definition-type slotd
)))
1301 ((eq type t
) slotd-type
)
1302 ;; This pairwise type intersection is perhaps a
1303 ;; little inefficient and inelegant, but it's
1304 ;; unlikely to lie on the critical path. Shout
1305 ;; if I'm wrong. -- CSR, 2005-11-24
1307 (specifier-type `(and ,type
,slotd-type
)))))))))
1310 :initfunction initfunction
1312 :allocation allocation
1313 :allocation-class allocation-class
1316 :documentation documentation
)))
1318 (defmethod compute-effective-slot-definition-initargs :around
1319 ((class structure-class
) direct-slotds
)
1320 (let* ((slotd (car direct-slotds
))
1321 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1322 (list* :defstruct-accessor-symbol accessor
1323 :internal-reader-function
1324 (slot-definition-internal-reader-function slotd
)
1325 :internal-writer-function
1326 (slot-definition-internal-writer-function slotd
)
1328 (slot-definition-always-bound-p slotd
)
1329 (call-next-method))))
1331 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1332 ;;; to make the method object. They have to use make-a-method which
1333 ;;; is a specially bootstrapped mechanism for making standard methods.
1334 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1335 (declare (ignore direct-slot initargs
))
1336 (find-class 'standard-reader-method
))
1338 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1339 (add-method generic-function
1340 (make-a-method 'standard-reader-method
1342 (list (or (class-name class
) 'object
))
1344 (make-reader-method-function class slot-name
)
1345 (or slot-documentation
"automatically generated reader method")
1346 :slot-name slot-name
1348 :method-class-function
#'reader-method-class
1349 'source source-location
)))
1351 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1352 (declare (ignore direct-slot initargs
))
1353 (find-class 'standard-writer-method
))
1355 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1356 (add-method generic-function
1357 (make-a-method 'standard-writer-method
1359 (list 'new-value
(or (class-name class
) 'object
))
1360 (list *the-class-t
* class
)
1361 (make-writer-method-function class slot-name
)
1362 (or slot-documentation
"automatically generated writer method")
1363 :slot-name slot-name
1365 :method-class-function
#'writer-method-class
1366 'source source-location
)))
1368 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1370 (and (= (length (arg-info-metatypes (gf-arg-info generic-function
))) 1)
1371 (get-method generic-function
() (list class
) nil
))))
1372 (when method
(remove-method generic-function method
))))
1374 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1376 (and (= (length (arg-info-metatypes (gf-arg-info generic-function
))) 2)
1377 (get-method generic-function
() (list *the-class-t
* class
) nil
))))
1378 (when method
(remove-method generic-function method
))))
1380 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1381 ;;; function are NOT part of the standard protocol. They are however
1382 ;;; useful; PCL makes use of them internally and documents them for
1383 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1385 ;;; *** This needs work to make type testing by the writer functions which
1386 ;;; *** do type testing faster. The idea would be to have one constructor
1387 ;;; *** for each possible type test.
1389 ;;; *** There is a subtle bug here which is going to have to be fixed.
1390 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1391 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1392 ;;; *** defined for this metaclass a chance to run.
1394 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1395 (make-std-reader-method-function class slot-name
))
1397 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1398 (make-std-writer-method-function class slot-name
))
1400 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1401 (eq (class-of class
) (class-of proto-new-class
)))
1403 (defmethod validate-superclass ((class class
) (superclass class
))
1404 (or (eq (class-of class
) (class-of superclass
))
1405 (and (eq (class-of superclass
) *the-class-standard-class
*)
1406 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1407 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1408 (eq (class-of class
) *the-class-standard-class
*))))
1410 ;;; What this does depends on which of the four possible values of
1411 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1412 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1413 ;;; nothing to do, as the new wrapper has already been created. If
1414 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1415 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1416 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1418 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1419 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1420 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1421 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1422 ;;; obsolete the wrapper.
1424 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1425 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1426 ;;; :UNINITIALIZED)))
1428 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1429 (defun %force-cache-flushes
(class)
1431 (let* ((owrapper (class-wrapper class
)))
1432 ;; We only need to do something if the wrapper is still valid. If
1433 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1434 ;; both of those will already be doing what we want. In
1435 ;; particular, we must be sure we never change an OBSOLETE into a
1436 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1437 (when (or (not (invalid-wrapper-p owrapper
))
1438 ;; KLUDGE: despite the observations above, this remains
1439 ;; a violation of locality or what might be considered
1440 ;; good style. There has to be a better way! -- CSR,
1442 (eq (layout-invalid owrapper
) t
))
1443 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1445 (setf (wrapper-slot-list nwrapper
) (wrapper-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 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1451 (if (find-if (lambda (x)
1452 (and (consp x
) (eq :obsolete
(car x
))))
1453 (layout-inherits owrapper
)
1454 :key
#'layout-invalid
)
1455 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1456 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1459 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1460 ;;; the next access to the instance (as defined in 88-002R) to trap
1461 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1462 (defmethod make-instances-obsolete ((class std-class
))
1464 (let* ((owrapper (class-wrapper class
))
1465 (nwrapper (make-wrapper (layout-length owrapper
)
1467 (unless (class-finalized-p class
)
1468 (if (class-has-a-forward-referenced-superclass-p class
)
1469 (return-from make-instances-obsolete class
)
1470 (%update-cpl class
(compute-class-precedence-list class
))))
1471 (setf (wrapper-slot-list nwrapper
) (wrapper-slot-list owrapper
))
1472 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1473 (%update-lisp-class-layout class nwrapper
)
1474 (setf (slot-value class
'wrapper
) nwrapper
)
1475 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1478 (defmethod make-instances-obsolete ((class symbol
))
1479 (make-instances-obsolete (find-class class
))
1480 ;; ANSI wants the class name when called with a symbol.
1483 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1484 ;;; see an obsolete instance. The times when it is called are:
1485 ;;; - when the instance is involved in method lookup
1486 ;;; - when attempting to access a slot of an instance
1488 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1489 ;;; instance access macros.
1491 ;;; Of course these times when it is called are an internal
1492 ;;; implementation detail of PCL and are not part of the documented
1493 ;;; description of when the obsolete instance update happens. The
1494 ;;; documented description is as it appears in 88-002R.
1496 ;;; This has to return the new wrapper, so it counts on all the
1497 ;;; methods on obsolete-instance-trap-internal to return the new
1498 ;;; wrapper. It also does a little internal error checking to make
1499 ;;; sure that the traps are only happening when they should, and that
1500 ;;; the trap methods are computing appropriate new wrappers.
1502 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1503 ;;; after a structure is redefined. In most cases,
1504 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1505 ;;; so it must signal an error. The hard part of this is that the
1506 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1507 ;;; called again, so in that case, we have to return some reasonable
1508 ;;; wrapper, instead.
1510 (defun %ensure-slot-value-type
(context slot-name slot-type value
1511 old-class new-class
)
1512 (do () ((typep value slot-type
))
1514 (error 'simple-type-error
1516 :expected-type slot-type
1519 "~@<Error during ~A. Current value in slot ~
1520 ~/sb-ext:print-symbol-with-prefix/ of an instance ~
1521 of ~S is ~S, which does not match the new slot type ~
1522 ~S in class ~S.~:@>")
1524 (list context slot-name old-class value slot-type new-class
))
1525 (use-value (new-value)
1526 :interactive read-evaluated-form
1527 :report
(lambda (stream)
1528 (format stream
"~@<Specify a new value to by used ~
1530 ~/sb-ext:print-symbol-with-prefix/ ~
1533 (setf value new-value
))))
1536 (defun %set-slot-value-checking-type
(context slots slot value
1537 safe old-class new-class
)
1538 (let ((value (if (and safe
(not (unbound-marker-p value
)))
1539 (let ((name (slot-definition-name slot
))
1540 (type (slot-definition-type slot
)))
1541 (%ensure-slot-value-type context name type value
1542 old-class new-class
))
1544 (setf (clos-slots-ref slots
(slot-definition-location slot
)) value
)))
1546 (defvar *in-obsolete-instance-trap
* nil
)
1548 (define-condition obsolete-structure
(error)
1549 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1551 (lambda (condition stream
)
1552 ;; Don't try to print the structure, since it probably won't work.
1554 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1555 (type-of (obsolete-structure-datum condition
))))))
1557 (macrolet ((replace-wrapper-and-slots (thing layout slot-vector
)
1558 `(if (functionp ,thing
)
1559 (setf (%fun-layout
,thing
) ,layout
1560 (fsc-instance-slots ,thing
) ,slot-vector
)
1561 ;; TODO: use a double-wide CAS here if CPU supports it
1563 (setf (%instance-layout
,thing
) ,layout
)
1564 (%instance-set
,thing sb-vm
:instance-data-start
,slot-vector
)))))
1566 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1568 ((layout-for-pcl-obj-p owrapper
)
1569 (binding* ((class (wrapper-class nwrapper
))
1570 (oslots (get-slots instance
))
1571 (nwrapper (class-wrapper class
))
1572 (nslots (make-array (layout-length nwrapper
)
1573 :initial-element
+slot-unbound
+))
1577 (safe (safe-p class
))
1578 ((new-instance-slots nil new-custom-slots
)
1579 (classify-slotds (wrapper-slot-list nwrapper
)))
1580 ((old-instance-slots old-class-slots old-custom-slots
)
1581 (classify-slotds (wrapper-slot-list owrapper
)))
1582 (layout (mapcar (lambda (slotd)
1583 ;; Get the names only once.
1584 (cons (slot-definition-name slotd
) slotd
))
1585 new-instance-slots
)))
1586 ;; local --> local transfer value, check type
1587 ;; local --> shared discard value, discard slot
1588 ;; local --> -- discard slot
1589 ;; local --> custom XXX
1591 ;; shared --> local transfer value, check type
1592 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1593 ;; shared --> -- discard value
1594 ;; shared --> custom XXX
1596 ;; -- --> local add slot
1598 ;; -- --> custom XXX
1599 (flet ((set-value (value cell
)
1600 (%set-slot-value-checking-type
1601 "updating obsolete instance"
1602 nslots
(cdr cell
) value safe class class
)
1603 ;; Prune from the list now that it's been dealt with.
1604 (setf layout
(remove cell layout
))))
1606 ;; Go through all the old local slots.
1607 (dolist (old old-instance-slots
)
1608 (let* ((name (slot-definition-name old
))
1609 (cell (find-slot-cell owrapper name
))
1610 (location (car cell
))
1613 (clos-slots-ref oslots location
))
1615 (clos-slots-ref oslots
(slot-info-location (cdr cell
))))
1616 (t (bug "non-FIXNUM non-NULL location in cell: ~S" cell
)))))
1617 (unless (unbound-marker-p value
)
1618 (let ((new (assq name layout
)))
1620 (set-value value new
))
1622 (push name discarded
)
1623 (setf (getf plist name
) value
)))))))
1625 ;; Go through all the old shared slots.
1626 (dolist (old old-class-slots
)
1627 (binding* ((cell (slot-definition-location old
))
1629 (new (assq name layout
) :exit-if-null
))
1630 (set-value (cdr cell
) new
)))
1632 ;; Go through all custom slots to find added ones. CLHS
1633 ;; doesn't specify what to do about them, and neither does
1634 ;; AMOP. We do want them to get initialized, though, so we
1635 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1636 (dolist (new new-custom-slots
)
1637 (let* ((name (slot-definition-name new
))
1638 (old (find name old-custom-slots
1639 :key
#'slot-definition-name
)))
1641 (push name added
))))
1643 ;; Go through all the remaining new local slots to compute
1645 (dolist (cell layout
)
1646 (push (car cell
) added
)))
1648 (replace-wrapper-and-slots instance nwrapper nslots
)
1649 ;; The obsolete instance protocol does not specify what happens if
1650 ;; an error is signaled in U-I-F-R-C and there is a nonlocal exit
1651 ;; outside; it may result in a half-updated instance whose
1652 ;; structure is updated but whose added slots are not initialized.
1653 ;; (See CLHS 3.7.2.)
1654 ;; The approach taken here is to abort the update process, as defined
1655 ;; in CLHS 4.3.6, altogether, and restore the instance to its obsolete
1656 ;; state; this way the programmer can try to fix the U-I-F-R-C code
1657 ;; which signaled an error and try to access the instance again
1658 ;; in order to try and update it again.
1659 (sb-sys:nlx-protect
(update-instance-for-redefined-class
1660 instance added discarded plist
)
1661 (replace-wrapper-and-slots instance owrapper oslots
))
1664 (*in-obsolete-instance-trap
* #.
(find-layout 'structure-object
))
1666 (let ((*in-obsolete-instance-trap
* t
))
1667 (error 'obsolete-structure
:datum instance
)))))
1669 (defun %change-class
(copy instance new-class initargs
)
1670 (binding* ((new-wrapper (class-wrapper (ensure-class-finalized new-class
)))
1671 (new-slots (make-array (layout-length new-wrapper
)
1672 :initial-element
+slot-unbound
+))
1673 (old-wrapper (layout-of instance
))
1674 (old-class (wrapper-class old-wrapper
))
1675 (old-slots (get-slots instance
))
1676 (safe (safe-p new-class
))
1677 (new-wrapper-slots (wrapper-slot-list new-wrapper
)))
1678 (replace-wrapper-and-slots copy new-wrapper new-slots
)
1679 (flet ((initarg-for-slot-p (slot)
1681 (dolist (slot-initarg (slot-definition-initargs slot
))
1682 (unless (unbound-marker-p
1683 (getf initargs slot-initarg
+slot-unbound
+))
1685 (set-value (value slotd
)
1686 (%set-slot-value-checking-type
1687 'change-class new-slots slotd value safe
1688 old-class new-class
)))
1690 ;; "The values of local slots specified by both the class CTO
1691 ;; and CFROM are retained. If such a local slot was unbound, it
1692 ;; remains unbound."
1693 (dolist (new new-wrapper-slots
)
1694 (when (and (not (initarg-for-slot-p new
))
1695 (eq (slot-definition-allocation new
) :instance
))
1696 (binding* ((cell (find-slot-cell old-wrapper
(slot-definition-name new
))
1698 (location (car cell
))
1701 (clos-slots-ref old-slots location
))
1703 (let ((info (cdr cell
)))
1704 (case (slot-info-allocation info
)
1706 (clos-slots-ref old-slots
(slot-info-location info
)))
1707 (:class
(cdr (slot-info-location info
))))))
1710 (set-value value new
)))))
1712 ;; Make the copy point to the old instance's storage, and make the
1713 ;; old instance point to the new storage.
1714 ;; All uses of %CHANGE-CLASS are under the world lock, but that doesn't
1715 ;; preclude user code operating on the old slots + new layout or v.v.
1716 ;; Users need to synchronize their own access when changing class.
1717 (replace-wrapper-and-slots copy old-wrapper old-slots
)
1718 (replace-wrapper-and-slots instance new-wrapper new-slots
)
1720 ;; The CLHS does not specify what happens if an error is signaled in
1721 ;; U-I-F-D-C and there is a nonlocal exit outside; it may result in a
1722 ;; half-updated instance whose class is updated but whose added slots
1723 ;; are not initialized. (See CLHS 3.7.2.)
1724 ;; The approach taken here is to abort the change-class process, as
1725 ;; defined in CLHS 4.3.6, altogether, and restore the instance to its
1726 ;; previous state; this way the programmer can try to fix the U-I-F-D-C
1727 ;; code which signaled an error and try to CHANGE-CLASS the instance
1729 (sb-sys:nlx-protect
(apply #'update-instance-for-different-class
1730 copy instance initargs
)
1731 (replace-wrapper-and-slots instance old-wrapper old-slots
))
1736 (defun check-new-class-not-metaobject (new-class)
1737 (dolist (class (class-precedence-list
1738 (ensure-class-finalized new-class
)))
1740 ((check-metaobject (class-name)
1741 `(when (eq class
(find-class ',class-name
))
1742 (change-class-to-metaobject-violation
1743 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1744 (check-metaobject class
)
1745 (check-metaobject generic-function
)
1746 (check-metaobject method
)
1747 (check-metaobject slot-definition
))))
1749 ;;; "The first argument to update-instance-for-different-class, /previous/,
1750 ;;; is that copy; it holds the old slot values temporarily. This argument has
1751 ;;; dynamic extent within change-class; if it is referenced in any way once
1752 ;;; update-instance-for-different-class returns, the results are undefined."
1753 ;;; The full ALLOCATE-INSTANCE protocol can not possibly support dynamic-extent
1754 ;;; allocation (at least, for SBCL; maybe for others it can).
1755 ;;; Calling ALLOCATE-INSTANCE from CHANGE-CLASS doesn't seem to be mandatory.
1756 ;;; At least 4 other Lisp implementations I tested don't call it.
1757 (macrolet ((with-temporary-instance ((var) &body body
)
1758 `(dx-let ((,var
(%make-instance
(1+ sb-vm
:instance-data-start
))))
1760 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1763 (check-new-class-not-metaobject new-class
)
1764 (with-temporary-instance (temp)
1765 (%change-class temp instance new-class initargs
))))
1767 (defmethod change-class ((instance forward-referenced-class
)
1768 (new-class standard-class
) &rest initargs
)
1770 (dolist (class (class-precedence-list
1771 (ensure-class-finalized new-class
))
1772 (change-class-to-metaobject-violation
1773 '(not class
) 'forward-referenced-class
1774 '((:amop
:generic-function ensure-class-using-class
)
1775 (:amop
:initialization class
))))
1776 (when (eq class
(find-class 'class
))
1778 (with-temporary-instance (temp)
1779 (%change-class temp instance new-class initargs
)))))
1781 (defmethod change-class ((instance t
)
1782 (new-class forward-referenced-class
) &rest initargs
)
1783 (declare (ignore initargs
))
1784 (change-class-to-metaobject-violation
1785 'forward-referenced-class nil
1786 '((:amop
:generic-function ensure-class-using-class
)
1787 (:amop
:initialization class
))))
1789 (macrolet ((with-temporary-funinstance ((var) &body body
)
1790 `(dx-let ((,var
(%make-funcallable-instance
1791 (+ sb-vm
:instance-data-start
2))))
1792 (dx-flet ((signal-error ()
1793 (declare (optimize (sb-c::verify-arg-count
0)))
1794 (error-no-implementation-function ,var
)))
1795 (setf (%funcallable-instance-fun
,var
) #'signal-error
)
1797 (defmethod change-class ((instance funcallable-standard-object
)
1798 (new-class funcallable-standard-class
)
1801 (check-new-class-not-metaobject new-class
)
1802 (with-temporary-funinstance (temp)
1803 (%change-class temp instance new-class initargs
)))))
1805 (defmethod change-class ((instance standard-object
)
1806 (new-class funcallable-standard-class
)
1808 (declare (ignore initargs
))
1809 (error "You can't change the class of ~S to ~S~@
1810 because it isn't already an instance with metaclass ~S."
1811 instance new-class
'funcallable-standard-class
))
1813 (defmethod change-class ((instance funcallable-standard-object
)
1814 (new-class standard-class
)
1816 (declare (ignore initargs
))
1817 (error "You can't change the class of ~S to ~S~@
1818 because it isn't already an instance with metaclass ~S."
1819 instance new-class
'standard-class
))
1821 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1822 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1824 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1826 ;;;; These metaclasses are something of a weird creature. By this
1827 ;;;; point, all instances which will exist have been created, and no
1828 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1829 ;;;; distinction between the metaclasses is that we allow subclassing
1830 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1831 ;;;; but not of BUILT-IN-CLASS.)
1833 ;;;; AMOP mandates some behaviour of the implementation with respect
1834 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1835 ;;;; SYSTEM-CLASS here.
1837 (macrolet ((def (name args control
)
1838 `(defmethod ,name
,args
1839 (declare (ignore initargs
))
1840 (error 'metaobject-initialization-violation
1841 :format-control
,(format nil
"~~@<~A~~@:>" control
)
1842 :format-arguments
(list (class-name class
))
1843 :references
'((:amop
:initialization
"Class"))))))
1844 (def initialize-instance
((class system-class
) &rest initargs
)
1845 "Cannot initialize an instance of ~S.")
1846 (def reinitialize-instance
((class system-class
) &rest initargs
)
1847 "Cannot reinitialize an instance of ~S."))
1849 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1850 (def class-direct-slots
)
1852 (def class-direct-default-initargs
)
1853 (def class-default-initargs
))
1855 (defmethod validate-superclass ((c class
) (s system-class
))
1857 (defmethod validate-superclass ((c class
) (s built-in-class
))
1860 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1861 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1862 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1863 (macrolet ((def (method)
1864 `(defmethod ,method
((class forward-referenced-class
))
1865 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1867 (def class-default-initargs
)
1868 (def class-precedence-list
)
1871 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1874 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1875 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1877 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1878 (setf (plist-value metaobject
'dependents
)
1879 (delete dependent
(plist-value metaobject
'dependents
))))
1881 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1882 (dolist (dependent (plist-value metaobject
'dependents
))
1883 (funcall function dependent
)))