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 (with-slots (prototype) class
151 (setf prototype
(allocate-instance class
)))))))
153 (def condition-class
)
154 (def structure-class
))
156 (defmethod class-direct-default-initargs ((class slot-class
))
157 (plist-value class
'direct-default-initargs
))
159 (defmethod class-default-initargs ((class slot-class
))
160 (plist-value class
'default-initargs
))
162 (defmethod class-slot-cells ((class std-class
))
163 (plist-value class
'class-slot-cells
))
164 (defmethod (setf class-slot-cells
) (new-value (class std-class
))
165 (setf (plist-value class
'class-slot-cells
) new-value
))
167 ;;;; class accessors that are even a little bit more complicated than those
168 ;;;; above. These have a protocol for updating them, we must implement that
171 ;;; Maintaining the direct subclasses backpointers. The update methods are
172 ;;; here, the values are read by an automatically generated reader method.
173 (defmethod add-direct-subclass ((class class
) (subclass class
))
174 (with-slots (direct-subclasses) class
175 (pushnew subclass direct-subclasses
:test
#'eq
)
177 (defmethod remove-direct-subclass ((class class
) (subclass class
))
178 (with-slots (direct-subclasses) class
179 (setq direct-subclasses
(remove subclass direct-subclasses
))
182 ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
184 ;;; There are four generic functions involved, each has one method for the
185 ;;; class case and another method for the damned EQL specializers. 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 ;;; 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 class
) (method method
))
216 (let ((cell (slot-value specializer
'direct-methods
)))
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 class
) (method method
))
225 (let ((cell (slot-value specializer
'direct-methods
)))
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 class
))
234 (with-slots (direct-methods) specializer
235 (car direct-methods
)))
237 (defmethod specializer-direct-generic-functions ((specializer class
))
238 (let ((cell (slot-value specializer
'direct-methods
)))
239 ;; If an ADD/REMOVE-METHOD is in progress, no matter: either
240 ;; we behave as if we got just first or just after -- it's just
241 ;; for update that we need to lock.
243 (sb-thread:with-mutex
(*specializer-lock
*)
246 (dolist (m (car cell
))
247 ;; the old PCL code used COLLECTING-ONCE which used
248 ;; #'EQ to check for newness
249 (pushnew (method-generic-function m
) collect
:test
#'eq
))
250 (nreverse collect
)))))))
252 ;;; This hash table is used to store the direct methods and direct generic
253 ;;; functions of EQL specializers. Each value in the table is the cons.
255 ;;; These tables are shared between threads, so they need to be synchronized.
256 (defvar *eql-specializer-methods
* (make-hash-table :test
'eql
:synchronized t
))
257 (defvar *class-eq-specializer-methods
* (make-hash-table :test
'eq
:synchronized t
))
259 (defmethod specializer-method-table ((specializer eql-specializer
))
260 *eql-specializer-methods
*)
262 (defmethod specializer-method-table ((specializer class-eq-specializer
))
263 *class-eq-specializer-methods
*)
265 (defmethod add-direct-method ((specializer specializer-with-object
)
267 (let* ((object (specializer-object specializer
))
268 (table (specializer-method-table specializer
))
269 (entry (gethash object table
)))
272 (setf (gethash object table
) (cons nil nil
))))
273 ;; We need to first smash the CDR, because a parallel read may
274 ;; be in progress, and because if an interrupt catches us we
275 ;; need to have a consistent state.
277 (car entry
) (adjoin method
(car entry
) :test
#'eq
))
280 (defmethod remove-direct-method ((specializer specializer-with-object
)
282 (let* ((object (specializer-object specializer
))
283 (entry (gethash object
(specializer-method-table specializer
))))
285 ;; We need to first smash the CDR, because a parallel read may
286 ;; be in progress, and because if an interrupt catches us we
287 ;; need to have a consistent state.
289 (car entry
) (remove method
(car entry
))))
292 (defmethod specializer-direct-methods ((specializer specializer-with-object
))
293 (car (gethash (specializer-object specializer
)
294 (specializer-method-table specializer
))))
296 (defmethod specializer-direct-generic-functions ((specializer
297 specializer-with-object
))
298 (let* ((object (specializer-object specializer
))
299 (entry (gethash object
(specializer-method-table specializer
))))
302 (sb-thread:with-mutex
(*specializer-lock
*)
305 (dolist (m (car entry
))
306 (pushnew (method-generic-function m
) collect
:test
#'eq
))
307 (nreverse collect
))))))))
309 (defun map-specializers (function)
310 (map-all-classes (lambda (class)
311 (funcall function
(class-eq-specializer class
))
312 (funcall function class
)))
313 (maphash (lambda (object methods
)
314 (declare (ignore methods
))
315 (intern-eql-specializer object
))
316 *eql-specializer-methods
*)
317 (maphash (lambda (object specl
)
318 (declare (ignore object
))
319 (funcall function specl
))
320 *eql-specializer-table
*)
323 (defun map-all-generic-functions (function)
324 (let ((all-generic-functions (make-hash-table :test
'eq
)))
325 (map-specializers (lambda (specl)
326 (dolist (gf (specializer-direct-generic-functions
328 (unless (gethash gf all-generic-functions
)
329 (setf (gethash gf all-generic-functions
) t
)
330 (funcall function gf
))))))
333 (defmethod shared-initialize :after
((specl class-eq-specializer
)
336 (declare (ignore slot-names
))
337 (setf (slot-value specl
'%type
) `(class-eq ,(specializer-class specl
))))
339 (defmethod shared-initialize :after
((specl eql-specializer
) slot-names
&key
)
340 (declare (ignore slot-names
))
341 (setf (slot-value specl
'%type
)
342 `(eql ,(specializer-object specl
)))
343 (setf (info :type
:translator specl
)
344 (make-eql-type (specializer-object specl
))))
346 (defun real-load-defclass (name metaclass-name supers slots other
347 readers writers slot-names source-location
&optional safe-p
)
348 (with-single-package-locked-error (:symbol name
"defining ~S as a class")
349 (%compiler-defclass name readers writers slot-names
)
350 (let ((res (apply #'ensure-class name
:metaclass metaclass-name
351 :direct-superclasses supers
353 :definition-source source-location
358 (setf (gdefinition 'load-defclass
) #'real-load-defclass
)
360 (defun ensure-class (name &rest args
)
362 (apply #'ensure-class-using-class
363 (let ((class (find-class name nil
)))
364 (when (and class
(eq name
(class-name class
)))
365 ;; NAME is the proper name of CLASS, so redefine it
369 (defun parse-ensure-class-args (class name args
)
370 (let ((metaclass *the-class-standard-class
*)
372 (reversed-plist '()))
373 (labels ((find-class* (which class-or-name
)
375 ((classp class-or-name
)
377 ((eq class-or-name class
)
378 (error "~@<Class ~A specified as its own ~
380 class-or-name which
))
383 ((and class-or-name
(legal-class-name-p class-or-name
))
385 ((eq class-or-name name
)
386 (error "~@<Class named ~
387 ~/sb-impl::print-symbol-with-prefix/ ~
388 specified as its own ~(~A~)class.~@:>"
389 class-or-name which
))
390 ((find-class class-or-name
(eq which
:meta
)))
392 class-or-name
:metaclass
'forward-referenced-class
))))
394 (error "~@<Not a class or a legal ~(~A~)class name: ~
396 which class-or-name
))))
397 (find-superclass (class-or-name)
398 (find-class* :super class-or-name
)))
399 (doplist (key value
) args
403 (setf metaclass
(find-class* :meta value
)
405 (:direct-superclasses
406 (let ((superclasses (mapcar #'find-superclass value
)))
407 (setf reversed-plist
(list* superclasses key reversed-plist
))))
409 (setf reversed-plist
(list* value key reversed-plist
)))))
410 (values metaclass
(nreverse reversed-plist
)))))
412 (defun call-with-ensure-class-context (class name args thunk
)
413 (let ((class (with-world-lock ()
414 (multiple-value-bind (metaclass initargs
)
415 (parse-ensure-class-args class name args
)
416 (let ((class (funcall thunk class name metaclass initargs
)))
417 (without-package-locks
418 (setf (find-class name
) class
)))))))
419 ;; After boot (SETF FIND-CLASS) does this.
420 (unless (eq **boot-state
** 'complete
)
421 (%set-class-type-translation class name
))
424 (defmethod ensure-class-using-class ((class null
) name
&rest args
&key
)
425 (call-with-ensure-class-context
426 class name args
(lambda (class name metaclass initargs
)
427 (declare (ignore class
))
428 (apply #'make-instance metaclass
:name name initargs
))))
430 (defmethod ensure-class-using-class ((class pcl-class
) name
&rest args
&key
)
431 (call-with-ensure-class-context
432 class name args
(lambda (class name metaclass initargs
)
433 (aver (eq name
(class-name class
)))
434 (unless (eq (class-of class
) metaclass
)
435 (apply #'change-class class metaclass initargs
))
436 (apply #'reinitialize-instance class initargs
)
439 ;;; This is used to call initfunctions of :allocation :class slots.
440 (defun call-initfun (fun slotd safe
)
441 (declare (function fun
))
442 (let ((value (funcall fun
)))
444 (let ((type (slot-definition-type slotd
)))
445 (unless (or (eq t type
)
447 (error 'type-error
:expected-type type
:datum value
))))
450 (defmethod shared-initialize :after
451 ((class std-class
) slot-names
&key
452 (direct-superclasses nil direct-superclasses-p
)
453 (direct-slots nil direct-slots-p
)
454 (direct-default-initargs nil direct-default-initargs-p
))
455 (cond (direct-superclasses-p
456 (setq direct-superclasses
457 (or direct-superclasses
458 (list (if (funcallable-standard-class-p class
)
459 *the-class-funcallable-standard-object
*
460 *the-class-standard-object
*))))
461 (dolist (superclass direct-superclasses
)
462 (unless (validate-superclass class superclass
)
463 (invalid-superclass class superclass
)))
464 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
466 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
469 (setf (slot-value class
'direct-slots
)
470 (mapcar (lambda (pl) (make-direct-slotd class pl
))
472 (slot-value class
'direct-slots
)))
473 (if direct-default-initargs-p
474 (setf (plist-value class
'direct-default-initargs
)
475 direct-default-initargs
)
476 (setq direct-default-initargs
477 (plist-value class
'direct-default-initargs
)))
478 (setf (plist-value class
'class-slot-cells
)
479 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
480 (safe (safe-p class
))
482 (dolist (dslotd direct-slots
)
483 (when (eq :class
(slot-definition-allocation dslotd
))
485 (let* ((name (slot-definition-name dslotd
))
486 (old (assoc name old-class-slot-cells
)))
489 (member name slot-names
:test
#'eq
))
490 (let* ((initfunction (slot-definition-initfunction dslotd
))
493 (call-initfun initfunction dslotd safe
)
495 (push (cons name value
) collect
))
496 (push old collect
)))))
498 (add-direct-subclasses class direct-superclasses
)
499 (if (class-finalized-p class
)
500 ;; required by AMOP, "Reinitialization of Class Metaobjects"
501 (finalize-inheritance class
)
502 (update-class class nil
))
503 (add-slot-accessors class direct-slots
)
504 (make-preliminary-layout class
))
506 (define-condition invalid-superclass
(reference-condition error
)
507 ((class :initarg
:class
:reader invalid-superclass-class
)
508 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
511 (let ((class (invalid-superclass-class c
))
512 (superclass (invalid-superclass-superclass c
)))
514 "~@<The class ~S was specified as a superclass of the ~
515 class ~S, but the metaclasses ~S and ~S are ~
516 incompatible.~@[ Define a method for ~S to avoid this ~
518 superclass class
(class-of superclass
) (class-of class
)
519 (and (typep superclass
'standard-class
)
520 'validate-superclass
))))))
522 (defmethod invalid-superclass ((class class
) (superclass class
))
523 (error 'invalid-superclass
:class class
:superclass superclass
524 :references
(list* '(:amop
:generic-function validate-superclass
)
525 (and (typep superclass
'built-in-class
)
526 (list '(:ansi-cl
:system-class built-in-class
)
527 '(:ansi-cl
:section
(4 3 7)))))))
529 (defmethod shared-initialize :after
((class forward-referenced-class
)
530 slot-names
&key
&allow-other-keys
)
531 (declare (ignore slot-names
))
532 (make-preliminary-layout class
))
534 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
536 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
537 ;;; make it known to the type system.
538 (defun make-preliminary-layout (class)
539 (flet ((compute-preliminary-cpl (root)
540 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
541 (compute-class-precedence-list root
))))
543 (without-package-locks
544 (unless (class-finalized-p class
)
545 (let ((name (class-name class
))) ; flushable?
546 (declare (ignore name
))
547 ;; KLUDGE: This is fairly horrible. We need to make a
548 ;; full-fledged CLASSOID here, not just tell the compiler that
549 ;; some class is forthcoming, because there are legitimate
550 ;; questions one can ask of the type system, implemented in
551 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
552 (let ((layout (make-wrapper 0 class
)))
553 (setf (slot-value class
'wrapper
) layout
)
554 (let ((cpl (compute-preliminary-cpl class
)))
555 (setf (layout-inherits layout
)
556 (order-layout-inherits
557 (map 'simple-vector
#'class-wrapper
558 (reverse (rest cpl
))))))
559 (register-layout layout
:invalidate t
)
560 (%set-class-type-translation class
(layout-classoid layout
)))))
561 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
564 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
565 (declare (ignore slot-names name
))
566 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
567 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
568 (setf (slot-value class
'%type
) `(class ,class
))
569 (setf (slot-value class
'class-eq-specializer
)
570 (make-instance 'class-eq-specializer
:class class
)))
572 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
573 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
574 (remove-direct-subclass old-super class
))
575 (remove-slot-accessors class
(class-direct-slots class
)))
577 (defmethod reinitialize-instance :after
((class slot-class
)
580 (map-dependents class
582 (apply #'update-dependent class dependent initargs
))))
584 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
585 (let* ((name (class-name class
))
586 (classoid (find-classoid name
))
587 (slots (condition-classoid-slots classoid
)))
588 ;; to balance the REMOVE-SLOT-ACCESSORS call in
589 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
591 (let ((slot-name (condition-slot-name slot
)))
592 (dolist (reader (condition-slot-readers slot
))
593 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
594 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
595 (sb-kernel::install-condition-slot-reader reader name slot-name
))
596 (dolist (writer (condition-slot-writers slot
))
597 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))
599 (defmethod shared-initialize :after
((class condition-class
) slot-names
600 &key direct-slots direct-superclasses
)
601 (declare (ignore slot-names
))
602 (let ((classoid (find-classoid (slot-value class
'name
))))
604 %class-precedence-list cpl-available-p finalized-p
605 prototype
(direct-supers direct-superclasses
)
608 (setf (slot-value class
'direct-slots
)
609 (mapcar (lambda (pl) (make-direct-slotd class pl
))
612 (classoid-pcl-class classoid
) class
613 direct-supers direct-superclasses
614 wrapper
(classoid-layout classoid
)
615 %class-precedence-list
(compute-class-precedence-list class
)
617 (getf plist
'direct-default-initargs
)
618 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
619 (add-direct-subclasses class direct-superclasses
)
620 (let ((slots (compute-slots class
)))
621 (setf (slot-value class
'slots
) slots
)
622 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
623 ;; Comment from Gerd's PCL, 2003-05-15:
625 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
626 ;; override condition accessors with generic functions. We do this
629 ;; ??? What does the above comment mean and why is it a good idea?
630 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
631 ;; comment) loses slot information in its condition classes:
632 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
633 ;; remove slot accessors but never put them back. I've added a
634 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
635 ;; was meant to happen? -- CSR, 2005-11-18
638 (defmethod direct-slot-definition-class ((class condition-class
)
640 (declare (ignore initargs
))
641 (find-class 'condition-direct-slot-definition
))
643 (defmethod effective-slot-definition-class ((class condition-class
)
645 (declare (ignore initargs
))
646 (find-class 'condition-effective-slot-definition
))
648 (defmethod finalize-inheritance ((class condition-class
))
649 (aver (slot-value class
'finalized-p
))
652 (defmethod compute-effective-slot-definition
653 ((class condition-class
) slot-name dslotds
)
654 (let* ((slotd (call-next-method))
655 (info (slot-definition-info slotd
)))
656 (setf (slot-info-reader info
)
658 (handler-case (condition-reader-function x slot-name
)
659 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
660 ;; is unbound; maybe it should be a CELL-ERROR of some
662 (error () (values (slot-unbound class x slot-name
))))))
663 (setf (slot-info-writer info
)
665 (condition-writer-function x v slot-name
)))
666 (setf (slot-info-boundp info
)
668 (multiple-value-bind (v c
)
669 (ignore-errors (condition-reader-function x slot-name
))
674 (defmethod compute-slots :around
((class condition-class
))
675 (let ((eslotds (call-next-method)))
676 (mapc #'finalize-internal-slot-functions eslotds
)
679 (defmethod shared-initialize :after
680 ((slotd structure-slot-definition
) slot-names
&key
681 (allocation :instance
) allocation-class
)
682 (declare (ignore slot-names allocation-class
))
683 (unless (eq allocation
:instance
)
684 (error "Structure slots must have :INSTANCE allocation.")))
686 (defun make-structure-class-defstruct-form (name direct-slots include
)
687 (let* ((conc-name (format-symbol *package
* "~S structure class " name
))
688 (constructor (format-symbol *package
* "~Aconstructor" conc-name
))
689 (included-name (class-name include
))
692 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
697 (dolist (slotd (reverse direct-slots
))
698 (let* ((slot-name (slot-definition-name slotd
))
699 (initform (slot-definition-initform slotd
))
700 (type (slot-definition-type slotd
))
701 (desc `(,slot-name
,initform
:type
,type
)))
702 (push `(slot-accessor ,name
,slot-name reader
)
704 (push `(slot-accessor ,name
,slot-name writer
)
706 (if (member slot-name included-slots
:test
#'eq
)
707 (push desc old-slots
)
708 (push desc new-slots
))))
709 (let* ((defstruct `(defstruct (,name
711 `((:include
,included-name
713 (:constructor
,constructor
())
715 (:conc-name
,conc-name
)
719 (mapcar (lambda (slotd reader-name
)
721 (slot-definition-defstruct-accessor-symbol
723 `(defun ,reader-name
(obj)
724 (declare (type ,name obj
))
726 direct-slots reader-names
))
728 (mapcar (lambda (slotd writer-name
)
730 (slot-definition-defstruct-accessor-symbol
732 `(defun ,writer-name
(nv obj
)
733 (declare (type ,name obj
))
734 (setf (,accessor obj
) nv
))))
735 direct-slots writer-names
))
739 ,@readers-init
,@writers-init
741 (values defstruct-form constructor reader-names writer-names
))))
743 (defun make-defstruct-allocation-function (name)
744 ;; FIXME: Why don't we go class->layout->info == dd
745 (let ((dd (find-defstruct-description name
)))
748 (%make-structure-instance-allocator dd nil
))
749 (funcallable-structure
750 (%make-funcallable-structure-instance-allocator dd nil
)))))
752 (defmethod shared-initialize :after
753 ((class structure-class
) slot-names
&key
754 (direct-superclasses nil direct-superclasses-p
)
755 (direct-slots nil direct-slots-p
)
756 direct-default-initargs
)
757 (declare (ignore slot-names direct-default-initargs
))
758 (if direct-superclasses-p
759 (setf (slot-value class
'direct-superclasses
)
760 (or direct-superclasses
761 (setq direct-superclasses
762 (and (not (eq (slot-value class
'name
) 'structure-object
))
763 (list *the-class-structure-object
*)))))
764 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
765 (let* ((name (slot-value class
'name
))
766 (from-defclass-p (slot-value class
'from-defclass-p
))
767 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
769 (setf (slot-value class
'direct-slots
)
773 (let* ((slot-name (getf pl
:name
))
775 (format-symbol *package
*
776 "~S structure class ~A"
778 (setq pl
(list* :defstruct-accessor-symbol
780 (make-direct-slotd class pl
))
782 (setq direct-slots
(slot-value class
'direct-slots
)))
784 (let ((include (car (slot-value class
'direct-superclasses
))))
785 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
786 (make-structure-class-defstruct-form name direct-slots include
)
787 (unless (structure-type-p name
) (eval defstruct-form
))
788 (mapc (lambda (dslotd reader-name writer-name
)
789 (let* ((reader (gdefinition reader-name
))
790 (writer (when (fboundp writer-name
)
791 (gdefinition writer-name
))))
792 (setf (slot-value dslotd
'internal-reader-function
)
794 (setf (slot-value dslotd
'internal-writer-function
)
796 direct-slots reader-names writer-names
)
797 (setf (slot-value class
'defstruct-form
) defstruct-form
)
798 (setf (slot-value class
'defstruct-constructor
) constructor
)))
799 (setf (slot-value class
'defstruct-constructor
)
800 ;; KLUDGE: not class; in fixup.lisp, can't access slots
801 ;; outside methods yet.
802 (make-defstruct-allocation-function name
)))
803 (add-direct-subclasses class direct-superclasses
)
804 (setf (slot-value class
'%class-precedence-list
)
805 (compute-class-precedence-list class
))
806 (setf (slot-value class
'cpl-available-p
) t
)
807 (let ((slots (compute-slots class
)))
808 (setf (slot-value class
'slots
) slots
)
809 (let* ((lclass (find-classoid (slot-value class
'name
)))
810 (layout (classoid-layout lclass
)))
811 (setf (classoid-pcl-class lclass
) class
)
812 (setf (slot-value class
'wrapper
) layout
)
813 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
814 (setf (slot-value class
'finalized-p
) t
)
815 (add-slot-accessors class direct-slots
)))
817 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
818 (declare (ignore initargs
))
819 (find-class 'structure-direct-slot-definition
))
821 (defmethod finalize-inheritance ((class structure-class
))
822 nil
) ; always finalized
824 (defun add-slot-accessors (class dslotds
)
825 (fix-slot-accessors class dslotds
'add
))
827 (defun remove-slot-accessors (class dslotds
)
828 (fix-slot-accessors class dslotds
'remove
))
830 (defun fix-slot-accessors (class dslotds add
/remove
)
831 (flet ((fix (gfspec name r
/w doc source-location
)
832 (let ((gf (cond ((eq add
/remove
'add
)
833 (or (find-generic-function gfspec nil
)
834 (ensure-generic-function
835 gfspec
:lambda-list
(case r
/w
837 (w '(new-value object
))))))
839 (find-generic-function gfspec nil
)))))
842 (r (if (eq add
/remove
'add
)
843 (add-reader-method class gf name doc source-location
)
844 (remove-reader-method class gf
)))
845 (w (if (eq add
/remove
'add
)
846 (add-writer-method class gf name doc source-location
)
847 (remove-writer-method class gf
))))))))
848 (dolist (dslotd dslotds
)
849 (let ((slot-name (slot-definition-name dslotd
))
850 (slot-doc (%slot-definition-documentation dslotd
))
851 (location (definition-source dslotd
)))
852 (dolist (r (slot-definition-readers dslotd
))
853 (fix r slot-name
'r slot-doc location
))
854 (dolist (w (slot-definition-writers dslotd
))
855 (fix w slot-name
'w slot-doc location
))))))
857 (defun add-direct-subclasses (class supers
)
858 (dolist (super supers
)
859 (unless (memq class
(class-direct-subclasses class
))
860 (add-direct-subclass super class
))))
862 (defmethod finalize-inheritance ((class std-class
))
863 (update-class class t
))
865 (defmethod finalize-inheritance ((class forward-referenced-class
))
866 ;; FIXME: should we not be thinking a bit about what kinds of error
867 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
868 ;; possibly a forward-referenced-class-error, though that's
869 ;; difficult given e.g. class precedence list calculations...
871 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
876 (defun class-has-a-forward-referenced-superclass-p (class)
877 (or (when (forward-referenced-class-p class
)
879 (some #'class-has-a-forward-referenced-superclass-p
880 (class-direct-superclasses class
))))
882 ;;; This is called by :after shared-initialize whenever a class is initialized
883 ;;; or reinitialized. The class may or may not be finalized.
884 (defun update-class (class finalizep
)
885 (labels ((rec (class finalizep
&optional
(seen '()))
886 (when (find class seen
:test
#'eq
)
887 (error "~@<Specified class ~S as a superclass of ~
890 (without-package-locks
892 (when (or finalizep
(class-finalized-p class
))
893 (%update-cpl class
(compute-class-precedence-list class
))
894 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
896 (%update-slots class
(compute-slots class
))
897 (update-gfs-of-class class
)
898 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
899 (update-ctors 'finalize-inheritance
:class class
))
900 (let ((seen (list* class seen
)))
901 (dolist (sub (class-direct-subclasses class
))
902 (rec sub nil seen
)))))))
903 (rec class finalizep
)))
905 (define-condition cpl-protocol-violation
(reference-condition error
)
906 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
907 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
908 (:default-initargs
:references
(list '(:sbcl
:node
"Metaobject Protocol")))
911 (format s
"~@<Protocol violation: the ~S class ~S ~
912 ~:[has~;does not have~] the class ~S in its ~
913 class precedence list: ~S.~@:>"
914 (class-name (class-of (cpl-protocol-violation-class c
)))
915 (cpl-protocol-violation-class c
)
916 (eq (class-of (cpl-protocol-violation-class c
))
917 *the-class-funcallable-standard-class
*)
918 (find-class 'function
)
919 (cpl-protocol-violation-cpl c
)))))
921 (defun class-has-a-cpl-protocol-violation-p (class)
922 (labels ((find-in-superclasses (class classes
)
925 ((eql class
(car classes
)) t
)
926 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
927 (let ((metaclass (class-of class
)))
929 ((eql metaclass
*the-class-standard-class
*)
930 (find-in-superclasses (find-class 'function
) (list class
)))
931 ((eql metaclass
*the-class-funcallable-standard-class
*)
932 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
934 (defun %update-cpl
(class cpl
)
935 (when (eq (class-of class
) *the-class-standard-class
*)
936 (when (find (find-class 'function
) cpl
)
937 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
938 (when (eq (class-of class
) *the-class-funcallable-standard-class
*)
939 (unless (find (find-class 'function
) cpl
)
940 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
941 (if (class-finalized-p class
)
942 (unless (and (equal (class-precedence-list class
) cpl
)
944 (when (position :class
(class-direct-slots c
)
945 :key
#'slot-definition-allocation
)
947 ;; comment from the old CMU CL sources:
948 ;; Need to have the cpl setup before %update-lisp-class-layout
949 ;; is called on CMU CL.
950 (setf (slot-value class
'%class-precedence-list
) cpl
)
951 (setf (slot-value class
'cpl-available-p
) t
)
952 (%force-cache-flushes class
))
954 (setf (slot-value class
'%class-precedence-list
) cpl
)
955 (setf (slot-value class
'cpl-available-p
) t
)))
956 (update-class-can-precede-p cpl
))
958 (defun update-class-can-precede-p (cpl)
960 (let ((first (car cpl
)))
961 (dolist (c (cdr cpl
))
962 (pushnew c
(slot-value first
'can-precede-list
) :test
#'eq
)))
963 (update-class-can-precede-p (cdr cpl
))))
965 (defun class-can-precede-p (class1 class2
)
966 (member class2
(class-can-precede-list class1
) :test
#'eq
))
968 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
970 ;;; In addition to slot locations (implicit in the ordering of the slots), we
971 ;;; must check classes: SLOT-INFO structures from old slotds may have been
972 ;;; cached in permutation vectors, but new slotds have had new ones allocated
973 ;;; to them. This is non-problematic for standard slotds, because we know the
974 ;;; structure is compatible, but if a slot definition class changes, this can
975 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
977 ;;; Also, if the slot has a non-standard allocation, we need to check that it
979 (defun slot-layouts-compatible-p
980 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
981 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
982 (classify-slotds oslotds
)
984 ;; Instance slots: name, type, and class.
985 (dolist (o old-instance-slotds
(not new-instance-slotds
))
986 (let ((n (pop new-instance-slotds
)))
988 (eq (slot-definition-name o
) (slot-definition-name n
))
989 (eq (slot-definition-type o
) (slot-definition-type n
))
990 (eq (class-of o
) (class-of n
)))
992 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
993 (dolist (o old-class-slotds
(not new-class-slotds
))
994 (let ((n (pop new-class-slotds
)))
996 (eq (slot-definition-name o
) (slot-definition-name n
))
997 (eq (class-of n
) (class-of o
)))
999 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
1000 (dolist (o old-custom-slotds
(not new-custom-slotds
))
1001 (let ((n (pop new-custom-slotds
)))
1003 (eq (slot-definition-name o
) (slot-definition-name n
))
1004 (eq (slot-definition-type o
) (slot-definition-type n
))
1005 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1006 (eq (class-of o
) (class-of n
)))
1009 (defun style-warn-about-duplicate-slots (class)
1010 (do* ((slots (slot-value class
'slots
) (cdr slots
))
1015 "~@<slot names with the same SYMBOL-NAME but ~
1016 different SYMBOL-PACKAGE (possible package problem) ~
1017 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1019 (let* ((slot-name (slot-definition-name (car slots
)))
1020 (oslots (and (not (eq (symbol-package slot-name
)
1023 (lambda (slot-name-2)
1024 (or (eq (symbol-package slot-name-2
)
1026 (string/= slot-name slot-name-2
)))
1028 :key
#'slot-definition-name
))))
1030 (pushnew (cons slot-name
1031 (mapcar #'slot-definition-name oslots
))
1033 :test
#'string
= :key
#'car
)))))
1035 (defun %update-slots
(class eslotds
)
1036 (multiple-value-bind (instance-slots class-slots custom-slots
)
1037 (classify-slotds eslotds
)
1038 (let* ((nslots (length instance-slots
))
1039 (owrapper (when (class-finalized-p class
) (class-wrapper class
)))
1041 (cond ((null owrapper
)
1042 (make-wrapper nslots class
))
1043 ((slot-layouts-compatible-p (layout-slot-list owrapper
)
1044 instance-slots class-slots custom-slots
)
1047 ;; This will initialize the new wrapper to have the
1048 ;; same state as the old wrapper. We will then have
1049 ;; to change that. This may seem like wasted work
1050 ;; (and it is), but the spec requires that we call
1051 ;; MAKE-INSTANCES-OBSOLETE.
1052 (make-instances-obsolete class
)
1053 (class-wrapper class
)))))
1054 (%update-lisp-class-layout class nwrapper
)
1055 (setf (slot-value class
'slots
) eslotds
1056 (layout-slot-list nwrapper
) eslotds
1057 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1058 (layout-length nwrapper
) nslots
1059 (slot-value class
'wrapper
) nwrapper
)
1060 (style-warn-about-duplicate-slots class
)
1061 (setf (slot-value class
'finalized-p
) t
)
1062 (unless (eq owrapper nwrapper
)
1063 (maybe-update-standard-slot-locations class
)))))
1065 (defun update-gf-dfun (class gf
)
1066 (let ((*new-class
* class
)
1067 (arg-info (gf-arg-info gf
)))
1069 ((special-case-for-compute-discriminating-function-p gf
))
1070 ((gf-precompute-dfun-and-emf-p arg-info
)
1071 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1072 (update-dfun gf dfun cache info
))))))
1074 (defun update-gfs-of-class (class)
1075 (when (and (class-finalized-p class
)
1076 (let ((cpl (class-precedence-list class
)))
1077 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1078 (member *the-class-standard-effective-slot-definition
*
1080 (let ((gf-table (make-hash-table :test
'eq
)))
1081 (labels ((collect-gfs (class)
1082 (dolist (gf (specializer-direct-generic-functions class
))
1083 (setf (gethash gf gf-table
) t
))
1084 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1086 (maphash (lambda (gf ignore
)
1087 (declare (ignore ignore
))
1088 (update-gf-dfun class gf
))
1091 (defmethod compute-default-initargs ((class slot-class
))
1092 (let ((initargs (loop for c in
(class-precedence-list class
)
1093 append
(class-direct-default-initargs c
))))
1094 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1096 ;;;; protocols for constructing direct and effective slot definitions
1098 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1099 (declare (ignore initargs
))
1100 (find-class 'standard-direct-slot-definition
))
1102 (defun make-direct-slotd (class initargs
)
1103 (apply #'make-instance
1104 (apply #'direct-slot-definition-class class initargs
)
1108 ;;; I (CSR) am not sure, but I believe that the particular order of
1109 ;;; slots is quite important: it is ideal to attempt to have a
1110 ;;; constant slot location for the same notional slots as much as
1111 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1112 ;;; al.) have a chance of working. The below at least walks through
1113 ;;; the slots predictably, but maybe it would be good to compute some
1114 ;;; kind of optimal slot layout by looking at locations of slots in
1116 (defun std-compute-slots (class)
1117 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1118 ;; for each different slot name we find in our superclasses. Each
1119 ;; call receives the class and a list of the dslotds with that name.
1120 ;; The list is in most-specific-first order.
1121 (let ((name-dslotds-alist ()))
1122 (dolist (c (reverse (class-precedence-list class
)))
1123 (dolist (slot (class-direct-slots c
))
1124 (let* ((name (slot-definition-name slot
))
1125 (entry (assq name name-dslotds-alist
)))
1127 (push slot
(cdr entry
))
1128 (push (list name slot
) name-dslotds-alist
)))))
1129 (mapcar (lambda (direct)
1130 (compute-effective-slot-definition class
1133 (nreverse name-dslotds-alist
))))
1135 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1136 (defmethod compute-slots ((class standard-class
))
1137 (std-compute-slots class
))
1138 (defmethod compute-slots ((class funcallable-standard-class
))
1139 (std-compute-slots class
))
1140 (defmethod compute-slots ((class structure-class
))
1141 (std-compute-slots class
))
1142 (defmethod compute-slots ((class condition-class
))
1143 (std-compute-slots class
))
1145 (defun std-compute-slots-around (class eslotds
)
1147 (safe (safe-p class
)))
1148 (dolist (eslotd eslotds eslotds
)
1149 (setf (slot-definition-location eslotd
)
1150 (case (slot-definition-allocation eslotd
)
1154 (let* ((name (slot-definition-name eslotd
))
1157 (slot-definition-allocation-class eslotd
)
1158 ;; we get here if the user adds an extra slot
1160 (setf (slot-definition-allocation-class eslotd
)
1162 ;; which raises the question of what we should
1163 ;; do if we find that said user has added a slot
1164 ;; with the same name as another slot...
1165 (cell (or (assq name
(class-slot-cells from-class
))
1166 (let ((c (cons name
+slot-unbound
+)))
1167 (push c
(class-slot-cells from-class
))
1170 (if (eq +slot-unbound
+ (cdr cell
))
1171 ;; We may have inherited an initfunction FIXME: Is this
1172 ;; really right? Is the initialization in
1173 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1174 (let ((initfun (slot-definition-initfunction eslotd
)))
1176 (rplacd cell
(call-initfun initfun eslotd safe
))
1179 (unless (slot-definition-class eslotd
)
1180 (setf (slot-definition-class eslotd
) class
))
1181 (initialize-internal-slot-functions eslotd
))))
1183 (defmethod compute-slots :around
((class standard-class
))
1184 (let ((eslotds (call-next-method)))
1185 (std-compute-slots-around class eslotds
)))
1186 (defmethod compute-slots :around
((class funcallable-standard-class
))
1187 (let ((eslotds (call-next-method)))
1188 (std-compute-slots-around class eslotds
)))
1189 (defmethod compute-slots :around
((class structure-class
))
1190 (let ((eslotds (call-next-method)))
1191 (mapc #'finalize-internal-slot-functions eslotds
)
1194 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1195 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1196 (class (apply #'effective-slot-definition-class class initargs
))
1197 (slotd (apply #'make-instance class initargs
)))
1200 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1201 (declare (ignore initargs
))
1202 (find-class 'standard-effective-slot-definition
))
1204 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1205 (declare (ignore initargs
))
1206 (find-class 'structure-effective-slot-definition
))
1208 (defmethod compute-effective-slot-definition-initargs
1209 ((class slot-class
) direct-slotds
)
1215 (allocation-class nil
)
1218 (documentationp nil
)
1223 (dolist (slotd direct-slotds
)
1226 (setq name
(slot-definition-name slotd
)
1229 (awhen (slot-definition-initfunction slotd
)
1230 (setq initform
(slot-definition-initform slotd
)
1233 (unless documentationp
1234 (awhen (%slot-definition-documentation slotd
)
1235 (setq documentation it
1238 (setq allocation
(slot-definition-allocation slotd
)
1239 allocation-class
(slot-definition-class slotd
)
1241 (setq initargs
(append (slot-definition-initargs slotd
) initargs
))
1242 (let ((slotd-type (slot-definition-type slotd
)))
1244 ((eq type t
) slotd-type
)
1245 ;; This pairwise type intersection is perhaps a
1246 ;; little inefficient and inelegant, but it's
1247 ;; unlikely to lie on the critical path. Shout
1248 ;; if I'm wrong. -- CSR, 2005-11-24
1250 (specifier-type `(and ,type
,slotd-type
)))))))))
1253 :initfunction initfunction
1255 :allocation allocation
1256 :allocation-class allocation-class
1259 :documentation documentation
)))
1261 (defmethod compute-effective-slot-definition-initargs :around
1262 ((class structure-class
) direct-slotds
)
1263 (let* ((slotd (car direct-slotds
))
1264 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1265 (list* :defstruct-accessor-symbol accessor
1266 :internal-reader-function
1267 (slot-definition-internal-reader-function slotd
)
1268 :internal-writer-function
1269 (slot-definition-internal-writer-function slotd
)
1270 (call-next-method))))
1272 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1273 ;;; to make the method object. They have to use make-a-method which
1274 ;;; is a specially bootstrapped mechanism for making standard methods.
1275 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1276 (declare (ignore direct-slot initargs
))
1277 (find-class 'standard-reader-method
))
1279 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1280 (add-method generic-function
1281 (make-a-method 'standard-reader-method
1283 (list (or (class-name class
) 'object
))
1285 (make-reader-method-function class slot-name
)
1286 (or slot-documentation
"automatically generated reader method")
1287 :slot-name slot-name
1289 :method-class-function
#'reader-method-class
1290 :definition-source source-location
)))
1292 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1293 (declare (ignore direct-slot initargs
))
1294 (find-class 'standard-writer-method
))
1296 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1297 (add-method generic-function
1298 (make-a-method 'standard-writer-method
1300 (list 'new-value
(or (class-name class
) 'object
))
1301 (list *the-class-t
* class
)
1302 (make-writer-method-function class slot-name
)
1303 (or slot-documentation
"automatically generated writer method")
1304 :slot-name slot-name
1306 :method-class-function
#'writer-method-class
1307 :definition-source source-location
)))
1309 (defmethod add-boundp-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1310 (add-method generic-function
1311 (make-a-method (constantly (find-class 'standard-boundp-method
))
1314 (list (or (class-name class
) 'object
))
1316 (make-boundp-method-function class slot-name
)
1317 (or slot-documentation
"automatically generated boundp method")
1318 :slot-name slot-name
1319 :definition-source source-location
)))
1321 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1322 (let ((method (get-method generic-function
() (list class
) nil
)))
1323 (when method
(remove-method generic-function method
))))
1325 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1327 (get-method generic-function
() (list *the-class-t
* class
) nil
)))
1328 (when method
(remove-method generic-function method
))))
1330 (defmethod remove-boundp-method ((class slot-class
) generic-function
)
1331 (let ((method (get-method generic-function
() (list class
) nil
)))
1332 (when method
(remove-method generic-function method
))))
1334 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1335 ;;; function are NOT part of the standard protocol. They are however
1336 ;;; useful; PCL makes use of them internally and documents them for
1337 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1339 ;;; *** This needs work to make type testing by the writer functions which
1340 ;;; *** do type testing faster. The idea would be to have one constructor
1341 ;;; *** for each possible type test.
1343 ;;; *** There is a subtle bug here which is going to have to be fixed.
1344 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1345 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1346 ;;; *** defined for this metaclass a chance to run.
1348 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1349 (make-std-reader-method-function class slot-name
))
1351 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1352 (make-std-writer-method-function class slot-name
))
1354 (defmethod make-boundp-method-function ((class slot-class
) slot-name
)
1355 (make-std-boundp-method-function class slot-name
))
1357 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1358 (eq (class-of class
) (class-of proto-new-class
)))
1360 (defmethod validate-superclass ((class class
) (superclass class
))
1361 (or (eq (class-of class
) (class-of superclass
))
1362 (and (eq (class-of superclass
) *the-class-standard-class
*)
1363 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1364 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1365 (eq (class-of class
) *the-class-standard-class
*))))
1367 ;;; What this does depends on which of the four possible values of
1368 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1369 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1370 ;;; nothing to do, as the new wrapper has already been created. If
1371 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1372 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1373 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1375 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1376 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1377 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1378 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1379 ;;; obsolete the wrapper.
1381 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1382 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1383 ;;; :UNINITIALIZED)))
1385 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1386 (defun %force-cache-flushes
(class)
1388 (let* ((owrapper (class-wrapper class
)))
1389 ;; We only need to do something if the wrapper is still valid. If
1390 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1391 ;; both of those will already be doing what we want. In
1392 ;; particular, we must be sure we never change an OBSOLETE into a
1393 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1394 (when (or (not (invalid-wrapper-p owrapper
))
1395 ;; KLUDGE: despite the observations above, this remains
1396 ;; a violation of locality or what might be considered
1397 ;; good style. There has to be a better way! -- CSR,
1399 (eq (layout-invalid owrapper
) t
))
1400 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1402 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1403 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1404 (%update-lisp-class-layout class nwrapper
)
1405 (setf (slot-value class
'wrapper
) nwrapper
)
1406 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1408 (if (find-if (lambda (x)
1409 (and (consp x
) (eq :obsolete
(car x
))))
1410 (layout-inherits owrapper
)
1411 :key
#'layout-invalid
)
1412 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1413 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1416 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1417 ;;; the next access to the instance (as defined in 88-002R) to trap
1418 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1419 (defmethod make-instances-obsolete ((class std-class
))
1421 (let* ((owrapper (class-wrapper class
))
1422 (nwrapper (make-wrapper (layout-length owrapper
)
1424 (unless (class-finalized-p class
)
1425 (if (class-has-a-forward-referenced-superclass-p class
)
1426 (return-from make-instances-obsolete class
)
1427 (%update-cpl class
(compute-class-precedence-list class
))))
1428 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1429 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1430 (%update-lisp-class-layout class nwrapper
)
1431 (setf (slot-value class
'wrapper
) nwrapper
)
1432 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1435 (defmethod make-instances-obsolete ((class symbol
))
1436 (make-instances-obsolete (find-class class
))
1437 ;; ANSI wants the class name when called with a symbol.
1440 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1441 ;;; see an obsolete instance. The times when it is called are:
1442 ;;; - when the instance is involved in method lookup
1443 ;;; - when attempting to access a slot of an instance
1445 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1446 ;;; instance access macros.
1448 ;;; Of course these times when it is called are an internal
1449 ;;; implementation detail of PCL and are not part of the documented
1450 ;;; description of when the obsolete instance update happens. The
1451 ;;; documented description is as it appears in 88-002R.
1453 ;;; This has to return the new wrapper, so it counts on all the
1454 ;;; methods on obsolete-instance-trap-internal to return the new
1455 ;;; wrapper. It also does a little internal error checking to make
1456 ;;; sure that the traps are only happening when they should, and that
1457 ;;; the trap methods are computing appropriate new wrappers.
1459 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1460 ;;; after a structure is redefined. In most cases,
1461 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1462 ;;; so it must signal an error. The hard part of this is that the
1463 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1464 ;;; called again, so in that case, we have to return some reasonable
1465 ;;; wrapper, instead.
1467 (defun %ensure-slot-value-type
(context slot-name slot-type value
1468 old-class new-class
)
1469 (do () ((typep value slot-type
))
1471 (bad-type value slot-type
1472 "~@<Error during ~A. Current value in slot ~
1473 ~/sb-impl::print-symbol-with-prefix/ of an instance ~
1474 of ~S is ~S, which does not match the new slot type ~
1475 ~S in class ~S.~:@>"
1476 context slot-name old-class value slot-type new-class
)
1477 (use-value (new-value)
1478 :interactive read-evaluated-form
1479 :report
(lambda (stream)
1480 (format stream
"~@<Specify a new value to by used ~
1482 ~/sb-impl::print-symbol-with-prefix/ ~
1485 (setf value new-value
))))
1488 (defun %set-slot-value-checking-type
(context slots slot value
1489 safe old-class new-class
)
1490 (setf (clos-slots-ref slots
(slot-definition-location slot
))
1491 (if (and safe
(neq value
+slot-unbound
+))
1492 (let ((name (slot-definition-name slot
))
1493 (type (slot-definition-type slot
)))
1494 (%ensure-slot-value-type context name type value
1495 old-class new-class
))
1498 (defvar *in-obsolete-instance-trap
* nil
)
1499 (defvar *the-wrapper-of-structure-object
*
1500 (class-wrapper (find-class 'structure-object
)))
1502 (define-condition obsolete-structure
(error)
1503 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1505 (lambda (condition stream
)
1506 ;; Don't try to print the structure, since it probably won't work.
1508 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1509 (type-of (obsolete-structure-datum condition
))))))
1511 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1513 ((layout-for-std-class-p owrapper
)
1514 (binding* ((class (wrapper-class* nwrapper
))
1515 (copy (allocate-instance class
)) ;??? allocate-instance ???
1516 (oslots (get-slots instance
))
1517 (nslots (get-slots copy
))
1521 (safe (safe-p class
))
1522 ((new-instance-slots nil new-custom-slots
)
1523 (classify-slotds (layout-slot-list nwrapper
)))
1524 ((old-instance-slots old-class-slots old-custom-slots
)
1525 (classify-slotds (layout-slot-list owrapper
)))
1526 (layout (mapcar (lambda (slotd)
1527 ;; Get the names only once.
1528 (cons (slot-definition-name slotd
) slotd
))
1529 new-instance-slots
)))
1530 ;; local --> local transfer value, check type
1531 ;; local --> shared discard value, discard slot
1532 ;; local --> -- discard slot
1533 ;; local --> custom XXX
1535 ;; shared --> local transfer value, check type
1536 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1537 ;; shared --> -- discard value
1538 ;; shared --> custom XXX
1540 ;; -- --> local add slot
1542 ;; -- --> custom XXX
1543 (flet ((set-value (value cell
)
1544 (%set-slot-value-checking-type
1545 "updating obsolete instance"
1546 nslots
(cdr cell
) value safe class class
)
1547 ;; Prune from the list now that it's been dealt with.
1548 (setf layout
(remove cell layout
))))
1550 ;; Go through all the old local slots.
1551 (dolist (old old-instance-slots
)
1552 (let* ((name (slot-definition-name old
))
1553 (value (clos-slots-ref oslots
(slot-definition-location old
))))
1554 (unless (eq value
+slot-unbound
+)
1555 (let ((new (assq name layout
)))
1557 (set-value value new
))
1559 (push name discarded
)
1560 (setf (getf plist name
) value
)))))))
1562 ;; Go through all the old shared slots.
1563 (dolist (old old-class-slots
)
1564 (binding* ((cell (slot-definition-location old
))
1566 (new (assq name layout
) :exit-if-null
))
1567 (set-value (cdr cell
) new
)))
1569 ;; Go through all custom slots to find added ones. CLHS
1570 ;; doesn't specify what to do about them, and neither does
1571 ;; AMOP. We do want them to get initialized, though, so we
1572 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1573 (dolist (new new-custom-slots
)
1574 (let* ((name (slot-definition-name new
))
1575 (old (find name old-custom-slots
1576 :key
#'slot-definition-name
)))
1578 (push name added
))))
1580 ;; Go through all the remaining new local slots to compute
1582 (dolist (cell layout
)
1583 (push (car cell
) added
)))
1585 (%swap-wrappers-and-slots instance copy
)
1587 (update-instance-for-redefined-class
1588 instance added discarded plist
)
1591 (*in-obsolete-instance-trap
*
1592 *the-wrapper-of-structure-object
*)
1594 (let ((*in-obsolete-instance-trap
* t
))
1595 (error 'obsolete-structure
:datum instance
)))))
1598 (defun %change-class
(instance new-class initargs
)
1599 (binding* ((old-class (class-of instance
))
1600 (copy (allocate-instance new-class
))
1601 (new-wrapper (get-wrapper copy
))
1602 (old-wrapper (class-wrapper old-class
))
1603 (old-slots (get-slots instance
))
1604 (new-slots (get-slots copy
))
1605 (safe (safe-p new-class
))
1607 (classify-slotds (layout-slot-list new-wrapper
)))
1608 ((old-instance-slots old-class-slots
)
1609 (classify-slotds (layout-slot-list old-wrapper
))))
1610 (labels ((find-slot (name slots
)
1611 (find name slots
:key
#'slot-definition-name
))
1612 (initarg-for-slot-p (slot)
1613 (dolist (slot-initarg (slot-definition-initargs slot
))
1614 ;; Abuse +slot-unbound+
1615 (unless (eq +slot-unbound
+
1616 (getf initargs slot-initarg
+slot-unbound
+))
1618 (set-value (value slotd
)
1619 (%set-slot-value-checking-type
1620 'change-class new-slots slotd value safe
1621 old-class new-class
)))
1623 ;; "The values of local slots specified by both the class CTO
1624 ;; and CFROM are retained. If such a local slot was unbound, it
1625 ;; remains unbound."
1626 (dolist (new new-instance-slots
)
1627 (unless (initarg-for-slot-p new
)
1628 (binding* ((old (find-slot (slot-definition-name new
) old-instance-slots
)
1630 (value (clos-slots-ref old-slots
(slot-definition-location old
))))
1631 (set-value value new
))))
1633 ;; "The values of slots specified as shared in the class CFROM and
1634 ;; as local in the class CTO are retained."
1635 (dolist (old old-class-slots
)
1636 (binding* ((slot-and-val (slot-definition-location old
))
1637 (new (find-slot (car slot-and-val
) new-instance-slots
)
1639 (set-value (cdr slot-and-val
) new
))))
1641 ;; Make the copy point to the old instance's storage, and make the
1642 ;; old instance point to the new storage.
1643 (%swap-wrappers-and-slots instance copy
)
1645 (apply #'update-instance-for-different-class copy instance initargs
)
1649 (defun check-new-class-not-metaobject (new-class)
1650 (dolist (class (class-precedence-list
1651 (ensure-class-finalized new-class
)))
1653 ((check-metaobject (class-name)
1654 `(when (eq class
(find-class ',class-name
))
1655 (change-class-to-metaobject-violation
1656 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1657 (check-metaobject class
)
1658 (check-metaobject generic-function
)
1659 (check-metaobject method
)
1660 (check-metaobject slot-definition
))))
1662 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1665 (check-new-class-not-metaobject new-class
)
1666 (%change-class instance new-class initargs
)))
1668 (defmethod change-class ((instance forward-referenced-class
)
1669 (new-class standard-class
) &rest initargs
)
1671 (dolist (class (class-precedence-list
1672 (ensure-class-finalized new-class
))
1673 (change-class-to-metaobject-violation
1674 '(not class
) 'forward-referenced-class
1675 '((:amop
:generic-function ensure-class-using-class
)
1676 (:amop
:initialization class
))))
1677 (when (eq class
(find-class 'class
))
1679 (%change-class instance new-class initargs
)))
1681 (defmethod change-class ((instance t
)
1682 (new-class forward-referenced-class
) &rest initargs
)
1683 (declare (ignore initargs
))
1684 (change-class-to-metaobject-violation
1685 'forward-referenced-class nil
1686 '((:amop
:generic-function ensure-class-using-class
)
1687 (:amop
:initialization class
))))
1689 (defmethod change-class ((instance funcallable-standard-object
)
1690 (new-class funcallable-standard-class
)
1693 (check-new-class-not-metaobject new-class
)
1694 (%change-class instance new-class initargs
)))
1696 (defmethod change-class ((instance standard-object
)
1697 (new-class funcallable-standard-class
)
1699 (declare (ignore initargs
))
1700 (error "You can't change the class of ~S to ~S~@
1701 because it isn't already an instance with metaclass ~S."
1702 instance new-class
'standard-class
))
1704 (defmethod change-class ((instance funcallable-standard-object
)
1705 (new-class standard-class
)
1707 (declare (ignore initargs
))
1708 (error "You can't change the class of ~S to ~S~@
1709 because it isn't already an instance with metaclass ~S."
1710 instance new-class
'funcallable-standard-class
))
1712 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1713 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1715 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1717 ;;;; These metaclasses are something of a weird creature. By this
1718 ;;;; point, all instances which will exist have been created, and no
1719 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1720 ;;;; distinction between the metaclasses is that we allow subclassing
1721 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1722 ;;;; but not of BUILT-IN-CLASS.)
1724 ;;;; AMOP mandates some behaviour of the implementation with respect
1725 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1726 ;;;; SYSTEM-CLASS here.
1728 (macrolet ((def (name args control
)
1729 `(defmethod ,name
,args
1730 (declare (ignore initargs
))
1731 (error 'metaobject-initialization-violation
1732 :format-control
,(format nil
"~@<~A~@:>" control
)
1733 :format-arguments
(list (class-name class
))
1734 :references
(list '(:amop
:initialization
"Class"))))))
1735 (def initialize-instance
((class system-class
) &rest initargs
)
1736 "Cannot initialize an instance of ~S.")
1737 (def reinitialize-instance
((class system-class
) &rest initargs
)
1738 "Cannot reinitialize an instance of ~S."))
1740 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1741 (def class-direct-slots
)
1743 (def class-direct-default-initargs
)
1744 (def class-default-initargs
))
1746 (defmethod validate-superclass ((c class
) (s system-class
))
1748 (defmethod validate-superclass ((c class
) (s built-in-class
))
1751 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1752 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1753 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1754 (macrolet ((def (method)
1755 `(defmethod ,method
((class forward-referenced-class
))
1756 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1758 (def class-default-initargs
)
1759 (def class-precedence-list
)
1762 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1765 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1766 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1768 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1769 (setf (plist-value metaobject
'dependents
)
1770 (delete dependent
(plist-value metaobject
'dependents
))))
1772 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1773 (dolist (dependent (plist-value metaobject
'dependents
))
1774 (funcall function dependent
)))