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-member-type :members
(list (specializer-object specl
)))))
346 (defun real-load-defclass (name metaclass-name supers slots other
347 readers writers slot-names source-location 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
)
456 (cond (direct-superclasses-p
457 (setq direct-superclasses
458 (or direct-superclasses
459 (list (if (funcallable-standard-class-p class
)
460 *the-class-funcallable-standard-object
*
461 *the-class-standard-object
*))))
462 (dolist (superclass direct-superclasses
)
463 (unless (validate-superclass class superclass
)
464 (invalid-superclass class superclass
)))
465 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
467 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
470 (setf (slot-value class
'direct-slots
)
471 (mapcar (lambda (pl) (make-direct-slotd class pl
))
473 (slot-value class
'direct-slots
)))
474 (if direct-default-initargs-p
475 (setf (plist-value class
'direct-default-initargs
)
476 direct-default-initargs
)
477 (setq direct-default-initargs
478 (plist-value class
'direct-default-initargs
)))
479 (setf (plist-value class
'class-slot-cells
)
480 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
481 (safe (safe-p class
))
483 (dolist (dslotd direct-slots
)
484 (when (eq :class
(slot-definition-allocation dslotd
))
486 (let* ((name (slot-definition-name dslotd
))
487 (old (assoc name old-class-slot-cells
)))
490 (member name slot-names
:test
#'eq
))
491 (let* ((initfunction (slot-definition-initfunction dslotd
))
494 (call-initfun initfunction dslotd safe
)
496 (push (cons name value
) collect
))
497 (push old collect
)))))
499 (add-direct-subclasses class direct-superclasses
)
500 (if (class-finalized-p class
)
501 ;; required by AMOP, "Reinitialization of Class Metaobjects"
502 (finalize-inheritance class
)
503 (update-class class nil
))
504 (add-slot-accessors class direct-slots definition-source
)
505 (make-preliminary-layout class
))
507 (define-condition invalid-superclass
(reference-condition error
)
508 ((class :initarg
:class
:reader invalid-superclass-class
)
509 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
512 (let ((class (invalid-superclass-class c
))
513 (superclass (invalid-superclass-superclass c
)))
515 "~@<The class ~S was specified as a superclass of the ~
516 class ~S, but the metaclasses ~S and ~S are ~
517 incompatible.~@[ Define a method for ~S to avoid this ~
519 superclass class
(class-of superclass
) (class-of class
)
520 (and (typep superclass
'standard-class
)
521 'validate-superclass
))))))
523 (defmethod invalid-superclass ((class class
) (superclass class
))
524 (error 'invalid-superclass
:class class
:superclass superclass
525 :references
(list* '(:amop
:generic-function validate-superclass
)
526 (and (typep superclass
'built-in-class
)
527 (list '(:ansi-cl
:system-class built-in-class
)
528 '(:ansi-cl
:section
(4 3 7)))))))
530 (defmethod shared-initialize :after
((class forward-referenced-class
)
531 slot-names
&key
&allow-other-keys
)
532 (declare (ignore slot-names
))
533 (make-preliminary-layout class
))
535 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
537 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
538 ;;; make it known to the type system.
539 (defun make-preliminary-layout (class)
540 (flet ((compute-preliminary-cpl (root)
541 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
542 (compute-class-precedence-list root
))))
544 (without-package-locks
545 (unless (class-finalized-p class
)
546 (let ((name (class-name class
))) ; flushable?
547 (declare (ignore name
))
548 ;; KLUDGE: This is fairly horrible. We need to make a
549 ;; full-fledged CLASSOID here, not just tell the compiler that
550 ;; some class is forthcoming, because there are legitimate
551 ;; questions one can ask of the type system, implemented in
552 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
553 (let ((layout (make-wrapper 0 class
)))
554 (setf (slot-value class
'wrapper
) layout
)
555 (let ((cpl (compute-preliminary-cpl class
)))
556 (setf (layout-inherits layout
)
557 (order-layout-inherits
558 (map 'simple-vector
#'class-wrapper
559 (reverse (rest cpl
))))))
560 (register-layout layout
:invalidate t
)
561 (%set-class-type-translation class
(layout-classoid layout
)))))
562 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
565 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
566 (declare (ignore slot-names name
))
567 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
568 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
569 (setf (slot-value class
'%type
) `(class ,class
))
570 (setf (slot-value class
'class-eq-specializer
)
571 (make-instance 'class-eq-specializer
:class class
)))
573 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
574 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
575 (remove-direct-subclass old-super class
))
576 (remove-slot-accessors class
(class-direct-slots class
)))
578 (defmethod reinitialize-instance :after
((class slot-class
)
581 (map-dependents class
583 (apply #'update-dependent class dependent initargs
))))
585 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
586 (let* ((name (class-name class
))
587 (classoid (find-classoid name
))
588 (slots (condition-classoid-slots classoid
)))
589 ;; to balance the REMOVE-SLOT-ACCESSORS call in
590 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
592 (let ((slot-name (condition-slot-name slot
)))
593 (dolist (reader (condition-slot-readers slot
))
594 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
595 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
596 (sb-kernel::install-condition-slot-reader reader name slot-name
))
597 (dolist (writer (condition-slot-writers slot
))
598 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))
600 (defmethod shared-initialize :after
((class condition-class
) slot-names
601 &key direct-slots direct-superclasses
)
602 (declare (ignore slot-names
))
603 (let ((classoid (find-classoid (slot-value class
'name
))))
605 %class-precedence-list cpl-available-p finalized-p
606 prototype
(direct-supers direct-superclasses
)
609 (setf (slot-value class
'direct-slots
)
610 (mapcar (lambda (pl) (make-direct-slotd class pl
))
613 (classoid-pcl-class classoid
) class
614 direct-supers direct-superclasses
615 wrapper
(classoid-layout classoid
)
616 %class-precedence-list
(compute-class-precedence-list class
)
618 (getf plist
'direct-default-initargs
)
619 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
620 (add-direct-subclasses class direct-superclasses
)
621 (let ((slots (compute-slots class
)))
622 (setf (slot-value class
'slots
) slots
)
623 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
624 ;; Comment from Gerd's PCL, 2003-05-15:
626 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
627 ;; override condition accessors with generic functions. We do this
630 ;; ??? What does the above comment mean and why is it a good idea?
631 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
632 ;; comment) loses slot information in its condition classes:
633 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
634 ;; remove slot accessors but never put them back. I've added a
635 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
636 ;; was meant to happen? -- CSR, 2005-11-18
639 (defmethod direct-slot-definition-class ((class condition-class
)
641 (declare (ignore initargs
))
642 (find-class 'condition-direct-slot-definition
))
644 (defmethod effective-slot-definition-class ((class condition-class
)
646 (declare (ignore initargs
))
647 (find-class 'condition-effective-slot-definition
))
649 (defmethod finalize-inheritance ((class condition-class
))
650 (aver (slot-value class
'finalized-p
))
653 (defmethod compute-effective-slot-definition
654 ((class condition-class
) slot-name dslotds
)
655 (let* ((slotd (call-next-method))
656 (info (slot-definition-info slotd
)))
657 (setf (slot-info-reader info
)
659 (handler-case (condition-reader-function x slot-name
)
660 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
661 ;; is unbound; maybe it should be a CELL-ERROR of some
663 (error () (values (slot-unbound class x slot-name
))))))
664 (setf (slot-info-writer info
)
666 (condition-writer-function x v slot-name
)))
667 (setf (slot-info-boundp info
)
669 (multiple-value-bind (v c
)
670 (ignore-errors (condition-reader-function x slot-name
))
675 (defmethod compute-slots :around
((class condition-class
))
676 (let ((eslotds (call-next-method)))
677 (mapc #'finalize-internal-slot-functions eslotds
)
680 (defmethod shared-initialize :after
681 ((slotd structure-slot-definition
) slot-names
&key
682 (allocation :instance
) allocation-class
)
683 (declare (ignore slot-names allocation-class
))
684 (unless (eq allocation
:instance
)
685 (error "Structure slots must have :INSTANCE allocation.")))
687 (defun make-structure-class-defstruct-form (name direct-slots include
)
688 (let* ((conc-name (format-symbol *package
* "~S structure class " name
))
689 (constructor (format-symbol *package
* "~Aconstructor" conc-name
))
690 (included-name (class-name include
))
693 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
698 (dolist (slotd (reverse direct-slots
))
699 (let* ((slot-name (slot-definition-name slotd
))
700 (initform (slot-definition-initform slotd
))
701 (type (slot-definition-type slotd
))
702 (desc `(,slot-name
,initform
:type
,type
)))
703 (push `(slot-accessor ,name
,slot-name reader
)
705 (push `(slot-accessor ,name
,slot-name writer
)
707 (if (member slot-name included-slots
:test
#'eq
)
708 (push desc old-slots
)
709 (push desc new-slots
))))
710 (let* ((defstruct `(defstruct (,name
712 `((:include
,included-name
714 (:constructor
,constructor
())
716 (:conc-name
,conc-name
)
720 (mapcar (lambda (slotd reader-name
)
722 (slot-definition-defstruct-accessor-symbol
724 `(defun ,reader-name
(obj)
725 (declare (type ,name obj
))
727 direct-slots reader-names
))
729 (mapcar (lambda (slotd writer-name
)
731 (slot-definition-defstruct-accessor-symbol
733 `(defun ,writer-name
(nv obj
)
734 (declare (type ,name obj
))
735 (setf (,accessor obj
) nv
))))
736 direct-slots writer-names
))
740 ,@readers-init
,@writers-init
742 (values defstruct-form constructor reader-names writer-names
))))
744 (defun make-defstruct-allocation-function (name)
745 ;; FIXME: Why don't we go class->layout->info == dd
746 (let ((dd (find-defstruct-description name
)))
749 (%make-structure-instance-allocator dd nil
))
750 (funcallable-structure
751 (%make-funcallable-structure-instance-allocator dd nil
)))))
753 (defmethod shared-initialize :after
754 ((class structure-class
) slot-names
&key
755 (direct-superclasses nil direct-superclasses-p
)
756 (direct-slots nil direct-slots-p
)
757 direct-default-initargs
759 (declare (ignore slot-names direct-default-initargs
))
760 (if direct-superclasses-p
761 (setf (slot-value class
'direct-superclasses
)
762 (or direct-superclasses
763 (setq direct-superclasses
764 (and (not (eq (slot-value class
'name
) 'structure-object
))
765 (list *the-class-structure-object
*)))))
766 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
767 (let* ((name (slot-value class
'name
))
768 (from-defclass-p (slot-value class
'from-defclass-p
))
769 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
771 (setf (slot-value class
'direct-slots
)
775 (let* ((slot-name (getf pl
:name
))
777 (format-symbol *package
*
778 "~S structure class ~A"
780 (setq pl
(list* :defstruct-accessor-symbol
782 (make-direct-slotd class pl
))
784 (setq direct-slots
(slot-value class
'direct-slots
)))
786 (let ((include (car (slot-value class
'direct-superclasses
))))
787 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
788 (make-structure-class-defstruct-form name direct-slots include
)
789 (unless (structure-type-p name
) (eval defstruct-form
))
790 (mapc (lambda (dslotd reader-name writer-name
)
791 (let* ((reader (gdefinition reader-name
))
792 (writer (when (fboundp writer-name
)
793 (gdefinition writer-name
))))
794 (setf (slot-value dslotd
'internal-reader-function
)
796 (setf (slot-value dslotd
'internal-writer-function
)
798 direct-slots reader-names writer-names
)
799 (setf (slot-value class
'defstruct-form
) defstruct-form
)
800 (setf (slot-value class
'defstruct-constructor
) constructor
)))
801 (setf (slot-value class
'defstruct-constructor
)
802 ;; KLUDGE: not class; in fixup.lisp, can't access slots
803 ;; outside methods yet.
804 (make-defstruct-allocation-function name
)))
805 (add-direct-subclasses class direct-superclasses
)
806 (setf (slot-value class
'%class-precedence-list
)
807 (compute-class-precedence-list class
))
808 (setf (slot-value class
'cpl-available-p
) t
)
809 (let ((slots (compute-slots class
)))
810 (setf (slot-value class
'slots
) slots
)
811 (let* ((lclass (find-classoid (slot-value class
'name
)))
812 (layout (classoid-layout lclass
)))
813 (setf (classoid-pcl-class lclass
) class
)
814 (setf (slot-value class
'wrapper
) layout
)
815 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
816 (setf (slot-value class
'finalized-p
) t
)
817 (add-slot-accessors class direct-slots definition-source
)))
819 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
820 (declare (ignore initargs
))
821 (find-class 'structure-direct-slot-definition
))
823 (defmethod finalize-inheritance ((class structure-class
))
824 nil
) ; always finalized
826 (defun add-slot-accessors (class dslotds
&optional source-location
)
827 (fix-slot-accessors class dslotds
'add source-location
))
829 (defun remove-slot-accessors (class dslotds
)
830 (fix-slot-accessors class dslotds
'remove
))
832 (defun fix-slot-accessors (class dslotds add
/remove
&optional source-location
)
833 (flet ((fix (gfspec name r
/w doc
)
834 (let ((gf (cond ((eq add
/remove
'add
)
835 (or (find-generic-function gfspec nil
)
836 (ensure-generic-function
837 gfspec
:lambda-list
(case r
/w
839 (w '(new-value object
))))))
841 (find-generic-function gfspec nil
)))))
844 (r (if (eq add
/remove
'add
)
845 (add-reader-method class gf name doc source-location
)
846 (remove-reader-method class gf
)))
847 (w (if (eq add
/remove
'add
)
848 (add-writer-method class gf name doc source-location
)
849 (remove-writer-method class gf
))))))))
850 (dolist (dslotd dslotds
)
851 (let ((slot-name (slot-definition-name dslotd
))
852 (slot-doc (%slot-definition-documentation dslotd
)))
853 (dolist (r (slot-definition-readers dslotd
))
854 (fix r slot-name
'r slot-doc
))
855 (dolist (w (slot-definition-writers dslotd
))
856 (fix w slot-name
'w slot-doc
))))))
858 (defun add-direct-subclasses (class supers
)
859 (dolist (super supers
)
860 (unless (memq class
(class-direct-subclasses class
))
861 (add-direct-subclass super class
))))
863 (defmethod finalize-inheritance ((class std-class
))
864 (update-class class t
))
866 (defmethod finalize-inheritance ((class forward-referenced-class
))
867 ;; FIXME: should we not be thinking a bit about what kinds of error
868 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
869 ;; possibly a forward-referenced-class-error, though that's
870 ;; difficult given e.g. class precedence list calculations...
872 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
877 (defun class-has-a-forward-referenced-superclass-p (class)
878 (or (when (forward-referenced-class-p class
)
880 (some #'class-has-a-forward-referenced-superclass-p
881 (class-direct-superclasses class
))))
883 ;;; This is called by :after shared-initialize whenever a class is initialized
884 ;;; or reinitialized. The class may or may not be finalized.
885 (defun update-class (class finalizep
)
886 (labels ((rec (class finalizep
&optional
(seen '()))
887 (when (find class seen
:test
#'eq
)
888 (error "~@<Specified class ~S as a superclass of ~
891 (without-package-locks
893 (when (or finalizep
(class-finalized-p class
))
894 (%update-cpl class
(compute-class-precedence-list class
))
895 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
897 (%update-slots class
(compute-slots class
))
898 (update-gfs-of-class class
)
899 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
900 (update-ctors 'finalize-inheritance
:class class
))
901 (let ((seen (list* class seen
)))
902 (dolist (sub (class-direct-subclasses class
))
903 (rec sub nil seen
)))))))
904 (rec class finalizep
)))
906 (define-condition cpl-protocol-violation
(reference-condition error
)
907 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
908 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
909 (:default-initargs
:references
(list '(:sbcl
:node
"Metaobject Protocol")))
912 (format s
"~@<Protocol violation: the ~S class ~S ~
913 ~:[has~;does not have~] the class ~S in its ~
914 class precedence list: ~S.~@:>"
915 (class-name (class-of (cpl-protocol-violation-class c
)))
916 (cpl-protocol-violation-class c
)
917 (eq (class-of (cpl-protocol-violation-class c
))
918 *the-class-funcallable-standard-class
*)
919 (find-class 'function
)
920 (cpl-protocol-violation-cpl c
)))))
922 (defun class-has-a-cpl-protocol-violation-p (class)
923 (labels ((find-in-superclasses (class classes
)
926 ((eql class
(car classes
)) t
)
927 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
928 (let ((metaclass (class-of class
)))
930 ((eql metaclass
*the-class-standard-class
*)
931 (find-in-superclasses (find-class 'function
) (list class
)))
932 ((eql metaclass
*the-class-funcallable-standard-class
*)
933 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
935 (defun %update-cpl
(class cpl
)
936 (when (eq (class-of class
) *the-class-standard-class
*)
937 (when (find (find-class 'function
) cpl
)
938 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
939 (when (eq (class-of class
) *the-class-funcallable-standard-class
*)
940 (unless (find (find-class 'function
) cpl
)
941 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
942 (if (class-finalized-p class
)
943 (unless (and (equal (class-precedence-list class
) cpl
)
945 (when (position :class
(class-direct-slots c
)
946 :key
#'slot-definition-allocation
)
948 ;; comment from the old CMU CL sources:
949 ;; Need to have the cpl setup before %update-lisp-class-layout
950 ;; is called on CMU CL.
951 (setf (slot-value class
'%class-precedence-list
) cpl
)
952 (setf (slot-value class
'cpl-available-p
) t
)
953 (%force-cache-flushes class
))
955 (setf (slot-value class
'%class-precedence-list
) cpl
)
956 (setf (slot-value class
'cpl-available-p
) t
)))
957 (update-class-can-precede-p cpl
))
959 (defun update-class-can-precede-p (cpl)
961 (let ((first (car cpl
)))
962 (dolist (c (cdr cpl
))
963 (pushnew c
(slot-value first
'can-precede-list
) :test
#'eq
)))
964 (update-class-can-precede-p (cdr cpl
))))
966 (defun class-can-precede-p (class1 class2
)
967 (member class2
(class-can-precede-list class1
) :test
#'eq
))
969 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
971 ;;; In addition to slot locations (implicit in the ordering of the slots), we
972 ;;; must check classes: SLOT-INFO structures from old slotds may have been
973 ;;; cached in permutation vectors, but new slotds have had new ones allocated
974 ;;; to them. This is non-problematic for standard slotds, because we know the
975 ;;; structure is compatible, but if a slot definition class changes, this can
976 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
978 ;;; Also, if the slot has a non-standard allocation, we need to check that it
980 (defun slot-layouts-compatible-p
981 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
982 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
983 (classify-slotds oslotds
)
985 ;; Instance slots: name, type, and class.
986 (dolist (o old-instance-slotds
(not new-instance-slotds
))
987 (let ((n (pop new-instance-slotds
)))
989 (eq (slot-definition-name o
) (slot-definition-name n
))
990 (eq (slot-definition-type o
) (slot-definition-type n
))
991 (eq (class-of o
) (class-of n
)))
993 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
994 (dolist (o old-class-slotds
(not new-class-slotds
))
995 (let ((n (pop new-class-slotds
)))
997 (eq (slot-definition-name o
) (slot-definition-name n
))
998 (eq (class-of n
) (class-of o
)))
1000 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
1001 (dolist (o old-custom-slotds
(not new-custom-slotds
))
1002 (let ((n (pop new-custom-slotds
)))
1004 (eq (slot-definition-name o
) (slot-definition-name n
))
1005 (eq (slot-definition-type o
) (slot-definition-type n
))
1006 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1007 (eq (class-of o
) (class-of n
)))
1010 (defun style-warn-about-duplicate-slots (class)
1011 (do* ((slots (slot-value class
'slots
) (cdr slots
))
1016 "~@<slot names with the same SYMBOL-NAME but ~
1017 different SYMBOL-PACKAGE (possible package problem) ~
1018 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1020 (let* ((slot-name (slot-definition-name (car slots
)))
1021 (oslots (and (not (eq (symbol-package slot-name
)
1024 (lambda (slot-name-2)
1025 (or (eq (symbol-package slot-name-2
)
1027 (string/= slot-name slot-name-2
)))
1029 :key
#'slot-definition-name
))))
1031 (pushnew (cons slot-name
1032 (mapcar #'slot-definition-name oslots
))
1034 :test
#'string
= :key
#'car
)))))
1036 (defun %update-slots
(class eslotds
)
1037 (multiple-value-bind (instance-slots class-slots custom-slots
)
1038 (classify-slotds eslotds
)
1039 (let* ((nslots (length instance-slots
))
1040 (owrapper (when (class-finalized-p class
) (class-wrapper class
)))
1042 (cond ((null owrapper
)
1043 (make-wrapper nslots class
))
1044 ((slot-layouts-compatible-p (layout-slot-list owrapper
)
1045 instance-slots class-slots custom-slots
)
1048 ;; This will initialize the new wrapper to have the
1049 ;; same state as the old wrapper. We will then have
1050 ;; to change that. This may seem like wasted work
1051 ;; (and it is), but the spec requires that we call
1052 ;; MAKE-INSTANCES-OBSOLETE.
1053 (make-instances-obsolete class
)
1054 (class-wrapper class
)))))
1055 (%update-lisp-class-layout class nwrapper
)
1056 (setf (slot-value class
'slots
) eslotds
1057 (layout-slot-list nwrapper
) eslotds
1058 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1059 (layout-length nwrapper
) nslots
1060 (slot-value class
'wrapper
) nwrapper
)
1061 (style-warn-about-duplicate-slots class
)
1062 (setf (slot-value class
'finalized-p
) t
)
1063 (unless (eq owrapper nwrapper
)
1064 (maybe-update-standard-slot-locations class
)))))
1066 (defun update-gf-dfun (class gf
)
1067 (let ((*new-class
* class
)
1068 (arg-info (gf-arg-info gf
)))
1070 ((special-case-for-compute-discriminating-function-p gf
))
1071 ((gf-precompute-dfun-and-emf-p arg-info
)
1072 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1073 (update-dfun gf dfun cache info
))))))
1075 (defun update-gfs-of-class (class)
1076 (when (and (class-finalized-p class
)
1077 (let ((cpl (class-precedence-list class
)))
1078 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1079 (member *the-class-standard-effective-slot-definition
*
1081 (let ((gf-table (make-hash-table :test
'eq
)))
1082 (labels ((collect-gfs (class)
1083 (dolist (gf (specializer-direct-generic-functions class
))
1084 (setf (gethash gf gf-table
) t
))
1085 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1087 (maphash (lambda (gf ignore
)
1088 (declare (ignore ignore
))
1089 (update-gf-dfun class gf
))
1092 (defmethod compute-default-initargs ((class slot-class
))
1093 (let ((initargs (loop for c in
(class-precedence-list class
)
1094 append
(class-direct-default-initargs c
))))
1095 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1097 ;;;; protocols for constructing direct and effective slot definitions
1099 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1100 (declare (ignore initargs
))
1101 (find-class 'standard-direct-slot-definition
))
1103 (defun make-direct-slotd (class initargs
)
1104 (apply #'make-instance
1105 (apply #'direct-slot-definition-class class initargs
)
1109 ;;; I (CSR) am not sure, but I believe that the particular order of
1110 ;;; slots is quite important: it is ideal to attempt to have a
1111 ;;; constant slot location for the same notional slots as much as
1112 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1113 ;;; al.) have a chance of working. The below at least walks through
1114 ;;; the slots predictably, but maybe it would be good to compute some
1115 ;;; kind of optimal slot layout by looking at locations of slots in
1117 (defun std-compute-slots (class)
1118 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1119 ;; for each different slot name we find in our superclasses. Each
1120 ;; call receives the class and a list of the dslotds with that name.
1121 ;; The list is in most-specific-first order.
1122 (let ((name-dslotds-alist ()))
1123 (dolist (c (reverse (class-precedence-list class
)))
1124 (dolist (slot (class-direct-slots c
))
1125 (let* ((name (slot-definition-name slot
))
1126 (entry (assq name name-dslotds-alist
)))
1128 (push slot
(cdr entry
))
1129 (push (list name slot
) name-dslotds-alist
)))))
1130 (mapcar (lambda (direct)
1131 (compute-effective-slot-definition class
1134 (nreverse name-dslotds-alist
))))
1136 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1137 (defmethod compute-slots ((class standard-class
))
1138 (std-compute-slots class
))
1139 (defmethod compute-slots ((class funcallable-standard-class
))
1140 (std-compute-slots class
))
1141 (defmethod compute-slots ((class structure-class
))
1142 (std-compute-slots class
))
1143 (defmethod compute-slots ((class condition-class
))
1144 (std-compute-slots class
))
1146 (defun std-compute-slots-around (class eslotds
)
1148 (safe (safe-p class
)))
1149 (dolist (eslotd eslotds eslotds
)
1150 (setf (slot-definition-location eslotd
)
1151 (case (slot-definition-allocation eslotd
)
1155 (let* ((name (slot-definition-name eslotd
))
1158 (slot-definition-allocation-class eslotd
)
1159 ;; we get here if the user adds an extra slot
1161 (setf (slot-definition-allocation-class eslotd
)
1163 ;; which raises the question of what we should
1164 ;; do if we find that said user has added a slot
1165 ;; with the same name as another slot...
1166 (cell (or (assq name
(class-slot-cells from-class
))
1167 (let ((c (cons name
+slot-unbound
+)))
1168 (push c
(class-slot-cells from-class
))
1171 (if (eq +slot-unbound
+ (cdr cell
))
1172 ;; We may have inherited an initfunction FIXME: Is this
1173 ;; really right? Is the initialization in
1174 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1175 (let ((initfun (slot-definition-initfunction eslotd
)))
1177 (rplacd cell
(call-initfun initfun eslotd safe
))
1180 (unless (slot-definition-class eslotd
)
1181 (setf (slot-definition-class eslotd
) class
))
1182 (initialize-internal-slot-functions eslotd
))))
1184 (defmethod compute-slots :around
((class standard-class
))
1185 (let ((eslotds (call-next-method)))
1186 (std-compute-slots-around class eslotds
)))
1187 (defmethod compute-slots :around
((class funcallable-standard-class
))
1188 (let ((eslotds (call-next-method)))
1189 (std-compute-slots-around class eslotds
)))
1190 (defmethod compute-slots :around
((class structure-class
))
1191 (let ((eslotds (call-next-method)))
1192 (mapc #'finalize-internal-slot-functions eslotds
)
1195 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1196 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1197 (class (apply #'effective-slot-definition-class class initargs
))
1198 (slotd (apply #'make-instance class initargs
)))
1201 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1202 (declare (ignore initargs
))
1203 (find-class 'standard-effective-slot-definition
))
1205 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1206 (declare (ignore initargs
))
1207 (find-class 'structure-effective-slot-definition
))
1209 (defmethod compute-effective-slot-definition-initargs
1210 ((class slot-class
) direct-slotds
)
1216 (allocation-class nil
)
1219 (documentationp nil
)
1224 (dolist (slotd direct-slotds
)
1227 (setq name
(slot-definition-name slotd
)
1230 (awhen (slot-definition-initfunction slotd
)
1231 (setq initform
(slot-definition-initform slotd
)
1234 (unless documentationp
1235 (awhen (%slot-definition-documentation slotd
)
1236 (setq documentation it
1239 (setq allocation
(slot-definition-allocation slotd
)
1240 allocation-class
(slot-definition-class slotd
)
1242 (setq initargs
(append (slot-definition-initargs slotd
) initargs
))
1243 (let ((slotd-type (slot-definition-type slotd
)))
1245 ((eq type t
) slotd-type
)
1246 ;; This pairwise type intersection is perhaps a
1247 ;; little inefficient and inelegant, but it's
1248 ;; unlikely to lie on the critical path. Shout
1249 ;; if I'm wrong. -- CSR, 2005-11-24
1251 (specifier-type `(and ,type
,slotd-type
)))))))))
1254 :initfunction initfunction
1256 :allocation allocation
1257 :allocation-class allocation-class
1260 :documentation documentation
)))
1262 (defmethod compute-effective-slot-definition-initargs :around
1263 ((class structure-class
) direct-slotds
)
1264 (let* ((slotd (car direct-slotds
))
1265 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1266 (list* :defstruct-accessor-symbol accessor
1267 :internal-reader-function
1268 (slot-definition-internal-reader-function slotd
)
1269 :internal-writer-function
1270 (slot-definition-internal-writer-function slotd
)
1271 (call-next-method))))
1273 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1274 ;;; to make the method object. They have to use make-a-method which
1275 ;;; is a specially bootstrapped mechanism for making standard methods.
1276 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1277 (declare (ignore direct-slot initargs
))
1278 (find-class 'standard-reader-method
))
1280 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1281 (add-method generic-function
1282 (make-a-method 'standard-reader-method
1284 (list (or (class-name class
) 'object
))
1286 (make-reader-method-function class slot-name
)
1287 (or slot-documentation
"automatically generated reader method")
1288 :slot-name slot-name
1290 :method-class-function
#'reader-method-class
1291 :definition-source source-location
)))
1293 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1294 (declare (ignore direct-slot initargs
))
1295 (find-class 'standard-writer-method
))
1297 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1298 (add-method generic-function
1299 (make-a-method 'standard-writer-method
1301 (list 'new-value
(or (class-name class
) 'object
))
1302 (list *the-class-t
* class
)
1303 (make-writer-method-function class slot-name
)
1304 (or slot-documentation
"automatically generated writer method")
1305 :slot-name slot-name
1307 :method-class-function
#'writer-method-class
1308 :definition-source source-location
)))
1310 (defmethod add-boundp-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1311 (add-method generic-function
1312 (make-a-method (constantly (find-class 'standard-boundp-method
))
1315 (list (or (class-name class
) 'object
))
1317 (make-boundp-method-function class slot-name
)
1318 (or slot-documentation
"automatically generated boundp method")
1319 :slot-name slot-name
1320 :definition-source source-location
)))
1322 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1323 (let ((method (get-method generic-function
() (list class
) nil
)))
1324 (when method
(remove-method generic-function method
))))
1326 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1328 (get-method generic-function
() (list *the-class-t
* class
) nil
)))
1329 (when method
(remove-method generic-function method
))))
1331 (defmethod remove-boundp-method ((class slot-class
) generic-function
)
1332 (let ((method (get-method generic-function
() (list class
) nil
)))
1333 (when method
(remove-method generic-function method
))))
1335 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1336 ;;; function are NOT part of the standard protocol. They are however
1337 ;;; useful; PCL makes use of them internally and documents them for
1338 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1340 ;;; *** This needs work to make type testing by the writer functions which
1341 ;;; *** do type testing faster. The idea would be to have one constructor
1342 ;;; *** for each possible type test.
1344 ;;; *** There is a subtle bug here which is going to have to be fixed.
1345 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1346 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1347 ;;; *** defined for this metaclass a chance to run.
1349 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1350 (make-std-reader-method-function class slot-name
))
1352 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1353 (make-std-writer-method-function class slot-name
))
1355 (defmethod make-boundp-method-function ((class slot-class
) slot-name
)
1356 (make-std-boundp-method-function class slot-name
))
1358 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1359 (eq (class-of class
) (class-of proto-new-class
)))
1361 (defmethod validate-superclass ((class class
) (superclass class
))
1362 (or (eq (class-of class
) (class-of superclass
))
1363 (and (eq (class-of superclass
) *the-class-standard-class
*)
1364 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1365 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1366 (eq (class-of class
) *the-class-standard-class
*))))
1368 ;;; What this does depends on which of the four possible values of
1369 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1370 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1371 ;;; nothing to do, as the new wrapper has already been created. If
1372 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1373 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1374 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1376 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1377 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1378 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1379 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1380 ;;; obsolete the wrapper.
1382 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1383 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1384 ;;; :UNINITIALIZED)))
1386 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1387 (defun %force-cache-flushes
(class)
1389 (let* ((owrapper (class-wrapper class
)))
1390 ;; We only need to do something if the wrapper is still valid. If
1391 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1392 ;; both of those will already be doing what we want. In
1393 ;; particular, we must be sure we never change an OBSOLETE into a
1394 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1395 (when (or (not (invalid-wrapper-p owrapper
))
1396 ;; KLUDGE: despite the observations above, this remains
1397 ;; a violation of locality or what might be considered
1398 ;; good style. There has to be a better way! -- CSR,
1400 (eq (layout-invalid owrapper
) t
))
1401 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1403 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1404 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1405 (%update-lisp-class-layout class nwrapper
)
1406 (setf (slot-value class
'wrapper
) nwrapper
)
1407 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1409 (if (find-if (lambda (x)
1410 (and (consp x
) (eq :obsolete
(car x
))))
1411 (layout-inherits owrapper
)
1412 :key
#'layout-invalid
)
1413 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1414 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1417 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1418 ;;; the next access to the instance (as defined in 88-002R) to trap
1419 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1420 (defmethod make-instances-obsolete ((class std-class
))
1422 (let* ((owrapper (class-wrapper class
))
1423 (nwrapper (make-wrapper (layout-length owrapper
)
1425 (unless (class-finalized-p class
)
1426 (if (class-has-a-forward-referenced-superclass-p class
)
1427 (return-from make-instances-obsolete class
)
1428 (%update-cpl class
(compute-class-precedence-list class
))))
1429 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1430 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1431 (%update-lisp-class-layout class nwrapper
)
1432 (setf (slot-value class
'wrapper
) nwrapper
)
1433 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1436 (defmethod make-instances-obsolete ((class symbol
))
1437 (make-instances-obsolete (find-class class
))
1438 ;; ANSI wants the class name when called with a symbol.
1441 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1442 ;;; see an obsolete instance. The times when it is called are:
1443 ;;; - when the instance is involved in method lookup
1444 ;;; - when attempting to access a slot of an instance
1446 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1447 ;;; instance access macros.
1449 ;;; Of course these times when it is called are an internal
1450 ;;; implementation detail of PCL and are not part of the documented
1451 ;;; description of when the obsolete instance update happens. The
1452 ;;; documented description is as it appears in 88-002R.
1454 ;;; This has to return the new wrapper, so it counts on all the
1455 ;;; methods on obsolete-instance-trap-internal to return the new
1456 ;;; wrapper. It also does a little internal error checking to make
1457 ;;; sure that the traps are only happening when they should, and that
1458 ;;; the trap methods are computing appropriate new wrappers.
1460 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1461 ;;; after a structure is redefined. In most cases,
1462 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1463 ;;; so it must signal an error. The hard part of this is that the
1464 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1465 ;;; called again, so in that case, we have to return some reasonable
1466 ;;; wrapper, instead.
1468 (defun %ensure-slot-value-type
(context slot-name slot-type value
1469 old-class new-class
)
1470 (do () ((typep value slot-type
))
1472 (bad-type value slot-type
1473 "~@<Error during ~A. Current value in slot ~
1474 ~/sb-impl::print-symbol-with-prefix/ of an instance ~
1475 of ~S is ~S, which does not match the new slot type ~
1476 ~S in class ~S.~:@>"
1477 context slot-name old-class value slot-type new-class
)
1478 (use-value (new-value)
1479 :interactive read-evaluated-form
1480 :report
(lambda (stream)
1481 (format stream
"~@<Specify a new value to by used ~
1483 ~/sb-impl::print-symbol-with-prefix/ ~
1486 (setf value new-value
))))
1489 (defun %set-slot-value-checking-type
(context slots slot value
1490 safe old-class new-class
)
1491 (setf (clos-slots-ref slots
(slot-definition-location slot
))
1492 (if (and safe
(neq value
+slot-unbound
+))
1493 (let ((name (slot-definition-name slot
))
1494 (type (slot-definition-type slot
)))
1495 (%ensure-slot-value-type context name type value
1496 old-class new-class
))
1499 (defvar *in-obsolete-instance-trap
* nil
)
1500 (defvar *the-wrapper-of-structure-object
*
1501 (class-wrapper (find-class 'structure-object
)))
1503 (define-condition obsolete-structure
(error)
1504 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1506 (lambda (condition stream
)
1507 ;; Don't try to print the structure, since it probably won't work.
1509 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1510 (type-of (obsolete-structure-datum condition
))))))
1512 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1514 ((layout-for-std-class-p owrapper
)
1515 (binding* ((class (wrapper-class* nwrapper
))
1516 (copy (allocate-instance class
)) ;??? allocate-instance ???
1517 (oslots (get-slots instance
))
1518 (nslots (get-slots copy
))
1522 (safe (safe-p class
))
1523 ((new-instance-slots nil new-custom-slots
)
1524 (classify-slotds (layout-slot-list nwrapper
)))
1525 ((old-instance-slots old-class-slots old-custom-slots
)
1526 (classify-slotds (layout-slot-list owrapper
)))
1527 (layout (mapcar (lambda (slotd)
1528 ;; Get the names only once.
1529 (cons (slot-definition-name slotd
) slotd
))
1530 new-instance-slots
)))
1531 ;; local --> local transfer value, check type
1532 ;; local --> shared discard value, discard slot
1533 ;; local --> -- discard slot
1534 ;; local --> custom XXX
1536 ;; shared --> local transfer value, check type
1537 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1538 ;; shared --> -- discard value
1539 ;; shared --> custom XXX
1541 ;; -- --> local add slot
1543 ;; -- --> custom XXX
1544 (flet ((set-value (value cell
)
1545 (%set-slot-value-checking-type
1546 "updating obsolete instance"
1547 nslots
(cdr cell
) value safe class class
)
1548 ;; Prune from the list now that it's been dealt with.
1549 (setf layout
(remove cell layout
))))
1551 ;; Go through all the old local slots.
1552 (dolist (old old-instance-slots
)
1553 (let* ((name (slot-definition-name old
))
1554 (value (clos-slots-ref oslots
(slot-definition-location old
))))
1555 (unless (eq value
+slot-unbound
+)
1556 (let ((new (assq name layout
)))
1558 (set-value value new
))
1560 (push name discarded
)
1561 (setf (getf plist name
) value
)))))))
1563 ;; Go through all the old shared slots.
1564 (dolist (old old-class-slots
)
1565 (binding* ((cell (slot-definition-location old
))
1567 (new (assq name layout
) :exit-if-null
))
1568 (set-value (cdr cell
) new
)))
1570 ;; Go through all custom slots to find added ones. CLHS
1571 ;; doesn't specify what to do about them, and neither does
1572 ;; AMOP. We do want them to get initialized, though, so we
1573 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1574 (dolist (new new-custom-slots
)
1575 (let* ((name (slot-definition-name new
))
1576 (old (find name old-custom-slots
1577 :key
#'slot-definition-name
)))
1579 (push name added
))))
1581 ;; Go through all the remaining new local slots to compute
1583 (dolist (cell layout
)
1584 (push (car cell
) added
)))
1586 (%swap-wrappers-and-slots instance copy
)
1588 (update-instance-for-redefined-class
1589 instance added discarded plist
)
1592 (*in-obsolete-instance-trap
*
1593 *the-wrapper-of-structure-object
*)
1595 (let ((*in-obsolete-instance-trap
* t
))
1596 (error 'obsolete-structure
:datum instance
)))))
1599 (defun %change-class
(instance new-class initargs
)
1600 (binding* ((old-class (class-of instance
))
1601 (copy (allocate-instance new-class
))
1602 (new-wrapper (get-wrapper copy
))
1603 (old-wrapper (class-wrapper old-class
))
1604 (old-slots (get-slots instance
))
1605 (new-slots (get-slots copy
))
1606 (safe (safe-p new-class
))
1608 (classify-slotds (layout-slot-list new-wrapper
)))
1609 ((old-instance-slots old-class-slots
)
1610 (classify-slotds (layout-slot-list old-wrapper
))))
1611 (labels ((find-slot (name slots
)
1612 (find name slots
:key
#'slot-definition-name
))
1613 (initarg-for-slot-p (slot)
1614 (dolist (slot-initarg (slot-definition-initargs slot
))
1615 ;; Abuse +slot-unbound+
1616 (unless (eq +slot-unbound
+
1617 (getf initargs slot-initarg
+slot-unbound
+))
1619 (set-value (value slotd
)
1620 (%set-slot-value-checking-type
1621 'change-class new-slots slotd value safe
1622 old-class new-class
)))
1624 ;; "The values of local slots specified by both the class CTO
1625 ;; and CFROM are retained. If such a local slot was unbound, it
1626 ;; remains unbound."
1627 (dolist (new new-instance-slots
)
1628 (unless (initarg-for-slot-p new
)
1629 (binding* ((old (find-slot (slot-definition-name new
) old-instance-slots
)
1631 (value (clos-slots-ref old-slots
(slot-definition-location old
))))
1632 (set-value value new
))))
1634 ;; "The values of slots specified as shared in the class CFROM and
1635 ;; as local in the class CTO are retained."
1636 (dolist (old old-class-slots
)
1637 (binding* ((slot-and-val (slot-definition-location old
))
1638 (new (find-slot (car slot-and-val
) new-instance-slots
)
1640 (set-value (cdr slot-and-val
) new
))))
1642 ;; Make the copy point to the old instance's storage, and make the
1643 ;; old instance point to the new storage.
1644 (%swap-wrappers-and-slots instance copy
)
1646 (apply #'update-instance-for-different-class copy instance initargs
)
1650 (defun check-new-class-not-metaobject (new-class)
1651 (dolist (class (class-precedence-list
1652 (ensure-class-finalized new-class
)))
1654 ((check-metaobject (class-name)
1655 `(when (eq class
(find-class ',class-name
))
1656 (change-class-to-metaobject-violation
1657 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1658 (check-metaobject class
)
1659 (check-metaobject generic-function
)
1660 (check-metaobject method
)
1661 (check-metaobject slot-definition
))))
1663 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1666 (check-new-class-not-metaobject new-class
)
1667 (%change-class instance new-class initargs
)))
1669 (defmethod change-class ((instance forward-referenced-class
)
1670 (new-class standard-class
) &rest initargs
)
1672 (dolist (class (class-precedence-list
1673 (ensure-class-finalized new-class
))
1674 (change-class-to-metaobject-violation
1675 '(not class
) 'forward-referenced-class
1676 '((:amop
:generic-function ensure-class-using-class
)
1677 (:amop
:initialization class
))))
1678 (when (eq class
(find-class 'class
))
1680 (%change-class instance new-class initargs
)))
1682 (defmethod change-class ((instance t
)
1683 (new-class forward-referenced-class
) &rest initargs
)
1684 (declare (ignore initargs
))
1685 (change-class-to-metaobject-violation
1686 'forward-referenced-class nil
1687 '((:amop
:generic-function ensure-class-using-class
)
1688 (:amop
:initialization class
))))
1690 (defmethod change-class ((instance funcallable-standard-object
)
1691 (new-class funcallable-standard-class
)
1694 (check-new-class-not-metaobject new-class
)
1695 (%change-class instance new-class initargs
)))
1697 (defmethod change-class ((instance standard-object
)
1698 (new-class funcallable-standard-class
)
1700 (declare (ignore initargs
))
1701 (error "You can't change the class of ~S to ~S~@
1702 because it isn't already an instance with metaclass ~S."
1703 instance new-class
'standard-class
))
1705 (defmethod change-class ((instance funcallable-standard-object
)
1706 (new-class standard-class
)
1708 (declare (ignore initargs
))
1709 (error "You can't change the class of ~S to ~S~@
1710 because it isn't already an instance with metaclass ~S."
1711 instance new-class
'funcallable-standard-class
))
1713 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1714 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1716 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1718 ;;;; These metaclasses are something of a weird creature. By this
1719 ;;;; point, all instances which will exist have been created, and no
1720 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1721 ;;;; distinction between the metaclasses is that we allow subclassing
1722 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1723 ;;;; but not of BUILT-IN-CLASS.)
1725 ;;;; AMOP mandates some behaviour of the implementation with respect
1726 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1727 ;;;; SYSTEM-CLASS here.
1729 (macrolet ((def (name args control
)
1730 `(defmethod ,name
,args
1731 (declare (ignore initargs
))
1732 (error 'metaobject-initialization-violation
1733 :format-control
,(format nil
"~@<~A~@:>" control
)
1734 :format-arguments
(list (class-name class
))
1735 :references
(list '(:amop
:initialization
"Class"))))))
1736 (def initialize-instance
((class system-class
) &rest initargs
)
1737 "Cannot initialize an instance of ~S.")
1738 (def reinitialize-instance
((class system-class
) &rest initargs
)
1739 "Cannot reinitialize an instance of ~S."))
1741 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1742 (def class-direct-slots
)
1744 (def class-direct-default-initargs
)
1745 (def class-default-initargs
))
1747 (defmethod validate-superclass ((c class
) (s system-class
))
1749 (defmethod validate-superclass ((c class
) (s built-in-class
))
1752 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1753 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1754 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1755 (macrolet ((def (method)
1756 `(defmethod ,method
((class forward-referenced-class
))
1757 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1759 (def class-default-initargs
)
1760 (def class-precedence-list
)
1763 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1766 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1767 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1769 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1770 (setf (plist-value metaobject
'dependents
)
1771 (delete dependent
(plist-value metaobject
'dependents
))))
1773 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1774 (dolist (dependent (plist-value metaobject
'dependents
))
1775 (funcall function dependent
)))