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 ;; Maybe the specializer object should point to the CTYPE directly?
344 (setf (info :type
:translator specl
)
345 (make-eql-type (specializer-object specl
))))
347 (defun real-load-defclass (name metaclass-name supers slots other
348 readers writers slot-names source-location
&optional safe-p
)
349 (with-single-package-locked-error (:symbol name
"defining ~S as a class")
350 (%compiler-defclass name readers writers slot-names
)
351 (let ((res (apply #'ensure-class name
:metaclass metaclass-name
352 :direct-superclasses supers
354 :definition-source source-location
359 (setf (gdefinition 'load-defclass
) #'real-load-defclass
)
361 (defun ensure-class (name &rest args
)
363 (apply #'ensure-class-using-class
364 (let ((class (find-class name nil
)))
365 (when (and class
(eq name
(class-name class
)))
366 ;; NAME is the proper name of CLASS, so redefine it
370 (defun parse-ensure-class-args (class name args
)
371 (let ((metaclass *the-class-standard-class
*)
373 (reversed-plist '()))
374 (labels ((find-class* (which class-or-name
)
376 ((classp class-or-name
)
378 ((eq class-or-name class
)
379 (error "~@<Class ~A specified as its own ~
381 class-or-name which
))
384 ((and class-or-name
(legal-class-name-p class-or-name
))
386 ((eq class-or-name name
)
387 (error "~@<Class named ~
388 ~/sb-impl::print-symbol-with-prefix/ ~
389 specified as its own ~(~A~)class.~@:>"
390 class-or-name which
))
391 ((find-class class-or-name
(eq which
:meta
)))
393 class-or-name
:metaclass
'forward-referenced-class
))))
395 (error "~@<Not a class or a legal ~(~A~)class name: ~
397 which class-or-name
))))
398 (find-superclass (class-or-name)
399 (find-class* :super class-or-name
)))
400 (doplist (key value
) args
404 (setf metaclass
(find-class* :meta value
)
406 (:direct-superclasses
407 (let ((superclasses (mapcar #'find-superclass value
)))
408 (setf reversed-plist
(list* superclasses key reversed-plist
))))
410 (setf reversed-plist
(list* value key reversed-plist
)))))
411 (values metaclass
(nreverse reversed-plist
)))))
413 (defun call-with-ensure-class-context (class name args thunk
)
414 (let ((class (with-world-lock ()
415 (multiple-value-bind (metaclass initargs
)
416 (parse-ensure-class-args class name args
)
417 (let ((class (funcall thunk class name metaclass initargs
)))
418 (without-package-locks
419 (setf (find-class name
) class
)))))))
422 (defmethod ensure-class-using-class ((class null
) name
&rest args
&key
)
423 (call-with-ensure-class-context
424 class name args
(lambda (class name metaclass initargs
)
425 (declare (ignore class
))
426 (apply #'make-instance metaclass
:name name initargs
))))
428 (defmethod ensure-class-using-class ((class pcl-class
) name
&rest args
&key
)
429 (call-with-ensure-class-context
430 class name args
(lambda (class name metaclass initargs
)
431 (aver (eq name
(class-name class
)))
432 (unless (eq (class-of class
) metaclass
)
433 (apply #'change-class class metaclass initargs
))
434 (apply #'reinitialize-instance class initargs
)
437 ;;; This is used to call initfunctions of :allocation :class slots.
438 (defun call-initfun (fun slotd safe
)
439 (declare (function fun
))
440 (let ((value (funcall fun
)))
442 (let ((type (slot-definition-type slotd
)))
443 (unless (or (eq t type
)
445 (error 'type-error
:expected-type type
:datum value
))))
448 (defmethod shared-initialize :after
449 ((class std-class
) slot-names
&key
450 (direct-superclasses nil direct-superclasses-p
)
451 (direct-slots nil direct-slots-p
)
452 (direct-default-initargs nil direct-default-initargs-p
))
453 (cond (direct-superclasses-p
454 (setq direct-superclasses
455 (or direct-superclasses
456 (list (if (funcallable-standard-class-p class
)
457 *the-class-funcallable-standard-object
*
458 *the-class-standard-object
*))))
459 (dolist (superclass direct-superclasses
)
460 (unless (validate-superclass class superclass
)
461 (invalid-superclass class superclass
)))
462 (setf (slot-value class
'direct-superclasses
) direct-superclasses
))
464 (setq direct-superclasses
(slot-value class
'direct-superclasses
))))
467 (setf (slot-value class
'direct-slots
)
468 (mapcar (lambda (pl) (make-direct-slotd class pl
))
470 (slot-value class
'direct-slots
)))
471 (if direct-default-initargs-p
472 (setf (plist-value class
'direct-default-initargs
)
473 direct-default-initargs
)
474 (setq direct-default-initargs
475 (plist-value class
'direct-default-initargs
)))
476 (setf (plist-value class
'class-slot-cells
)
477 (let ((old-class-slot-cells (plist-value class
'class-slot-cells
))
478 (safe (safe-p class
))
480 (dolist (dslotd direct-slots
)
481 (when (eq :class
(slot-definition-allocation dslotd
))
483 (let* ((name (slot-definition-name dslotd
))
484 (old (assoc name old-class-slot-cells
)))
487 (member name slot-names
:test
#'eq
))
488 (let* ((initfunction (slot-definition-initfunction dslotd
))
491 (call-initfun initfunction dslotd safe
)
493 (push (cons name value
) collect
))
494 (push old collect
)))))
496 (add-direct-subclasses class direct-superclasses
)
497 (if (class-finalized-p class
)
498 ;; required by AMOP, "Reinitialization of Class Metaobjects"
499 (finalize-inheritance class
)
500 (update-class class nil
))
501 (add-slot-accessors class direct-slots
)
502 (make-preliminary-layout class
))
504 (define-condition invalid-superclass
(reference-condition error
)
505 ((class :initarg
:class
:reader invalid-superclass-class
)
506 (superclass :initarg
:superclass
:reader invalid-superclass-superclass
))
509 (let ((class (invalid-superclass-class c
))
510 (superclass (invalid-superclass-superclass c
)))
512 "~@<The class ~S was specified as a superclass of the ~
513 class ~S, but the metaclasses ~S and ~S are ~
514 incompatible.~@[ Define a method for ~S to avoid this ~
516 superclass class
(class-of superclass
) (class-of class
)
517 (and (typep superclass
'standard-class
)
518 'validate-superclass
))))))
520 (defmethod invalid-superclass ((class class
) (superclass class
))
521 (error 'invalid-superclass
:class class
:superclass superclass
522 :references
(list* '(:amop
:generic-function validate-superclass
)
523 (and (typep superclass
'built-in-class
)
524 (list '(:ansi-cl
:system-class built-in-class
)
525 '(:ansi-cl
:section
(4 3 7)))))))
527 (defmethod shared-initialize :after
((class forward-referenced-class
)
528 slot-names
&key
&allow-other-keys
)
529 (declare (ignore slot-names
))
530 (make-preliminary-layout class
))
532 (defvar *allow-forward-referenced-classes-in-cpl-p
* nil
)
534 ;;; Give CLASS a preliminary layout if it doesn't have one already, to
535 ;;; make it known to the type system.
536 (defun make-preliminary-layout (class)
537 (flet ((compute-preliminary-cpl (root)
538 (let ((*allow-forward-referenced-classes-in-cpl-p
* t
))
539 (compute-class-precedence-list root
))))
541 (without-package-locks
542 (unless (class-finalized-p class
)
543 (let ((name (class-name class
))) ; flushable?
544 (declare (ignore name
))
545 ;; KLUDGE: This is fairly horrible. We need to make a
546 ;; full-fledged CLASSOID here, not just tell the compiler that
547 ;; some class is forthcoming, because there are legitimate
548 ;; questions one can ask of the type system, implemented in
549 ;; terms of CLASSOIDs, involving forward-referenced classes. So.
550 (let ((layout (make-wrapper 0 class
)))
551 (setf (slot-value class
'wrapper
) layout
)
552 (let ((cpl (compute-preliminary-cpl class
)))
553 (setf (layout-inherits layout
)
554 (order-layout-inherits
555 (map 'simple-vector
#'class-wrapper
556 (reverse (rest cpl
))))))
557 (register-layout layout
:invalidate t
))))
558 (mapc #'make-preliminary-layout
(class-direct-subclasses class
))))))
561 (defmethod shared-initialize :before
((class class
) slot-names
&key name
)
562 (declare (ignore slot-names name
))
563 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
564 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
565 (setf (slot-value class
'%type
) `(class ,class
))
566 (setf (slot-value class
'class-eq-specializer
)
567 (make-instance 'class-eq-specializer
:class class
)))
569 (defmethod reinitialize-instance :before
((class slot-class
) &key direct-superclasses
)
570 (dolist (old-super (set-difference (class-direct-superclasses class
) direct-superclasses
))
571 (remove-direct-subclass old-super class
))
572 (remove-slot-accessors class
(class-direct-slots class
)))
574 (defmethod reinitialize-instance :after
((class slot-class
)
577 (map-dependents class
579 (apply #'update-dependent class dependent initargs
))))
581 (defmethod reinitialize-instance :after
((class condition-class
) &key
)
582 (let* ((name (class-name class
))
583 (classoid (find-classoid name
))
584 (slots (condition-classoid-slots classoid
)))
585 ;; to balance the REMOVE-SLOT-ACCESSORS call in
586 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
588 (let ((slot-name (condition-slot-name slot
)))
589 (dolist (reader (condition-slot-readers slot
))
590 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
591 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
592 (sb-kernel::install-condition-slot-reader reader name slot-name
))
593 (dolist (writer (condition-slot-writers slot
))
594 (sb-kernel::install-condition-slot-writer writer name slot-name
))))))
596 (defmethod shared-initialize :after
((class condition-class
) slot-names
597 &key direct-slots direct-superclasses
)
598 (declare (ignore slot-names
))
599 (let ((classoid (find-classoid (slot-value class
'name
))))
601 %class-precedence-list cpl-available-p finalized-p
602 prototype
(direct-supers direct-superclasses
)
605 (setf (slot-value class
'direct-slots
)
606 (mapcar (lambda (pl) (make-direct-slotd class pl
))
609 (classoid-pcl-class classoid
) class
610 direct-supers direct-superclasses
611 wrapper
(classoid-layout classoid
)
612 %class-precedence-list
(compute-class-precedence-list class
)
614 (getf plist
'direct-default-initargs
)
615 (sb-kernel::condition-classoid-direct-default-initargs classoid
))
616 (add-direct-subclasses class direct-superclasses
)
617 (let ((slots (compute-slots class
)))
618 (setf (slot-value class
'slots
) slots
)
619 (setf (layout-slot-table wrapper
) (make-slot-table class slots
)))))
620 ;; Comment from Gerd's PCL, 2003-05-15:
622 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
623 ;; override condition accessors with generic functions. We do this
626 ;; ??? What does the above comment mean and why is it a good idea?
627 ;; CMUCL (which still as of 2005-11-18 uses this code and has this
628 ;; comment) loses slot information in its condition classes:
629 ;; DIRECT-SLOTS is always NIL. We have the right information, so we
630 ;; remove slot accessors but never put them back. I've added a
631 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
632 ;; was meant to happen? -- CSR, 2005-11-18
635 (defmethod direct-slot-definition-class ((class condition-class
)
637 (declare (ignore initargs
))
638 (find-class 'condition-direct-slot-definition
))
640 (defmethod effective-slot-definition-class ((class condition-class
)
642 (declare (ignore initargs
))
643 (find-class 'condition-effective-slot-definition
))
645 (defmethod finalize-inheritance ((class condition-class
))
646 (aver (slot-value class
'finalized-p
))
649 (defmethod compute-effective-slot-definition
650 ((class condition-class
) slot-name dslotds
)
651 (let* ((slotd (call-next-method))
652 (info (slot-definition-info slotd
)))
653 (setf (slot-info-reader info
)
655 (handler-case (condition-reader-function x slot-name
)
656 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
657 ;; is unbound; maybe it should be a CELL-ERROR of some
659 (error () (values (slot-unbound class x slot-name
))))))
660 (setf (slot-info-writer info
)
662 (condition-writer-function x v slot-name
)))
663 (setf (slot-info-boundp info
)
665 (multiple-value-bind (v c
)
666 (ignore-errors (condition-reader-function x slot-name
))
671 (defmethod compute-slots :around
((class condition-class
))
672 (let ((eslotds (call-next-method)))
673 (mapc #'finalize-internal-slot-functions eslotds
)
676 (defmethod shared-initialize :after
677 ((slotd structure-slot-definition
) slot-names
&key
678 (allocation :instance
) allocation-class
)
679 (declare (ignore slot-names allocation-class
))
680 (unless (eq allocation
:instance
)
681 (error "Structure slots must have :INSTANCE allocation.")))
683 (defun make-structure-class-defstruct-form (name direct-slots include
)
684 (let* ((conc-name (format-symbol *package
* "~S structure class " name
))
685 (constructor (format-symbol *package
* "~Aconstructor" conc-name
))
686 (included-name (class-name include
))
689 (mapcar #'dsd-name
(dd-slots (find-defstruct-description included-name
)))))
694 (dolist (slotd (reverse direct-slots
))
695 (let* ((slot-name (slot-definition-name slotd
))
696 (initform (slot-definition-initform slotd
))
697 (type (slot-definition-type slotd
))
698 (desc `(,slot-name
,initform
:type
,type
)))
699 (push `(slot-accessor ,name
,slot-name reader
)
701 (push `(slot-accessor ,name
,slot-name writer
)
703 (if (member slot-name included-slots
:test
#'eq
)
704 (push desc old-slots
)
705 (push desc new-slots
))))
706 (let* ((defstruct `(defstruct (,name
708 `((:include
,included-name
710 (:constructor
,constructor
())
712 (:conc-name
,conc-name
)
716 (mapcar (lambda (slotd reader-name
)
718 (slot-definition-defstruct-accessor-symbol
720 `(defun ,reader-name
(obj)
721 (declare (type ,name obj
))
723 direct-slots reader-names
))
725 (mapcar (lambda (slotd writer-name
)
727 (slot-definition-defstruct-accessor-symbol
729 `(defun ,writer-name
(nv obj
)
730 (declare (type ,name obj
))
731 (setf (,accessor obj
) nv
))))
732 direct-slots writer-names
))
736 ,@readers-init
,@writers-init
738 (values defstruct-form constructor reader-names writer-names
))))
740 (defun make-defstruct-allocation-function (name)
741 ;; FIXME: Why don't we go class->layout->info == dd
742 (let ((dd (find-defstruct-description name
)))
745 (%make-structure-instance-allocator dd nil
))
746 (funcallable-structure
747 (%make-funcallable-structure-instance-allocator dd nil
)))))
749 (defmethod shared-initialize :after
750 ((class structure-class
) slot-names
&key
751 (direct-superclasses nil direct-superclasses-p
)
752 (direct-slots nil direct-slots-p
)
753 direct-default-initargs
)
754 (declare (ignore slot-names direct-default-initargs
))
755 (if direct-superclasses-p
756 (setf (slot-value class
'direct-superclasses
)
757 (or direct-superclasses
758 (setq direct-superclasses
759 (and (not (eq (slot-value class
'name
) 'structure-object
))
760 (list *the-class-structure-object
*)))))
761 (setq direct-superclasses
(slot-value class
'direct-superclasses
)))
762 (let* ((name (slot-value class
'name
))
763 (from-defclass-p (slot-value class
'from-defclass-p
))
764 (defstruct-p (or from-defclass-p
(not (structure-type-p name
)))))
766 (setf (slot-value class
'direct-slots
)
770 (let* ((slot-name (getf pl
:name
))
772 (format-symbol *package
*
773 "~S structure class ~A"
775 (setq pl
(list* :defstruct-accessor-symbol
777 (make-direct-slotd class pl
))
779 (setq direct-slots
(slot-value class
'direct-slots
)))
781 (let ((include (car (slot-value class
'direct-superclasses
))))
782 (multiple-value-bind (defstruct-form constructor reader-names writer-names
)
783 (make-structure-class-defstruct-form name direct-slots include
)
784 (unless (structure-type-p name
) (eval defstruct-form
))
785 (mapc (lambda (dslotd reader-name writer-name
)
786 (let* ((reader (gdefinition reader-name
))
787 (writer (when (fboundp writer-name
)
788 (gdefinition writer-name
))))
789 (setf (slot-value dslotd
'internal-reader-function
)
791 (setf (slot-value dslotd
'internal-writer-function
)
793 direct-slots reader-names writer-names
)
794 (setf (slot-value class
'defstruct-form
) defstruct-form
)
795 (setf (slot-value class
'defstruct-constructor
) constructor
)))
796 (setf (slot-value class
'defstruct-constructor
)
797 ;; KLUDGE: not class; in fixup.lisp, can't access slots
798 ;; outside methods yet.
799 (make-defstruct-allocation-function name
)))
800 (add-direct-subclasses class direct-superclasses
)
801 (setf (slot-value class
'%class-precedence-list
)
802 (compute-class-precedence-list class
))
803 (setf (slot-value class
'cpl-available-p
) t
)
804 (let ((slots (compute-slots class
)))
805 (setf (slot-value class
'slots
) slots
)
806 (let* ((lclass (find-classoid (slot-value class
'name
)))
807 (layout (classoid-layout lclass
)))
808 (setf (classoid-pcl-class lclass
) class
)
809 (setf (slot-value class
'wrapper
) layout
)
810 (setf (layout-slot-table layout
) (make-slot-table class slots
))))
811 (setf (slot-value class
'finalized-p
) t
)
812 (add-slot-accessors class direct-slots
)))
814 (defmethod direct-slot-definition-class ((class structure-class
) &rest initargs
)
815 (declare (ignore initargs
))
816 (find-class 'structure-direct-slot-definition
))
818 (defmethod finalize-inheritance ((class structure-class
))
819 nil
) ; always finalized
821 (defun add-slot-accessors (class dslotds
)
822 (fix-slot-accessors class dslotds
'add
))
824 (defun remove-slot-accessors (class dslotds
)
825 (fix-slot-accessors class dslotds
'remove
))
827 (defun fix-slot-accessors (class dslotds add
/remove
)
828 (flet ((fix (gfspec name r
/w doc source-location
)
829 (let ((gf (cond ((eq add
/remove
'add
)
830 (or (find-generic-function gfspec nil
)
831 (ensure-generic-function
832 gfspec
:lambda-list
(case r
/w
834 (w '(new-value object
))))))
836 (find-generic-function gfspec nil
)))))
839 (r (if (eq add
/remove
'add
)
840 (add-reader-method class gf name doc source-location
)
841 (remove-reader-method class gf
)))
842 (w (if (eq add
/remove
'add
)
843 (add-writer-method class gf name doc source-location
)
844 (remove-writer-method class gf
))))))))
845 (dolist (dslotd dslotds
)
846 (let ((slot-name (slot-definition-name dslotd
))
847 (slot-doc (%slot-definition-documentation dslotd
))
848 (location (definition-source dslotd
)))
849 (dolist (r (slot-definition-readers dslotd
))
850 (fix r slot-name
'r slot-doc location
))
851 (dolist (w (slot-definition-writers dslotd
))
852 (fix w slot-name
'w slot-doc location
))))))
854 (defun add-direct-subclasses (class supers
)
855 (dolist (super supers
)
856 (unless (memq class
(class-direct-subclasses class
))
857 (add-direct-subclass super class
))))
859 (defmethod finalize-inheritance ((class std-class
))
860 (update-class class t
))
862 (defmethod finalize-inheritance ((class forward-referenced-class
))
863 ;; FIXME: should we not be thinking a bit about what kinds of error
864 ;; we're throwing? Maybe we need a clos-error type to mix in? Or
865 ;; possibly a forward-referenced-class-error, though that's
866 ;; difficult given e.g. class precedence list calculations...
868 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~
873 (defun class-has-a-forward-referenced-superclass-p (class)
874 (or (when (forward-referenced-class-p class
)
876 (some #'class-has-a-forward-referenced-superclass-p
877 (class-direct-superclasses class
))))
879 ;;; This is called by :after shared-initialize whenever a class is initialized
880 ;;; or reinitialized. The class may or may not be finalized.
881 (defun update-class (class finalizep
)
882 (labels ((rec (class finalizep
&optional
(seen '()))
883 (when (find class seen
:test
#'eq
)
884 (error "~@<Specified class ~S as a superclass of ~
887 (without-package-locks
889 (when (or finalizep
(class-finalized-p class
))
890 (%update-cpl class
(compute-class-precedence-list class
))
891 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
893 (%update-slots class
(compute-slots class
))
894 (update-gfs-of-class class
)
895 (setf (plist-value class
'default-initargs
) (compute-default-initargs class
))
896 (update-ctors 'finalize-inheritance
:class class
))
897 (let ((seen (list* class seen
)))
898 (dolist (sub (class-direct-subclasses class
))
899 (rec sub nil seen
)))))))
900 (rec class finalizep
)))
902 (define-condition cpl-protocol-violation
(reference-condition error
)
903 ((class :initarg
:class
:reader cpl-protocol-violation-class
)
904 (cpl :initarg
:cpl
:reader cpl-protocol-violation-cpl
))
905 (:default-initargs
:references
(list '(:sbcl
:node
"Metaobject Protocol")))
908 (format s
"~@<Protocol violation: the ~S class ~S ~
909 ~:[has~;does not have~] the class ~S in its ~
910 class precedence list: ~S.~@:>"
911 (class-name (class-of (cpl-protocol-violation-class c
)))
912 (cpl-protocol-violation-class c
)
913 (eq (class-of (cpl-protocol-violation-class c
))
914 *the-class-funcallable-standard-class
*)
915 (find-class 'function
)
916 (cpl-protocol-violation-cpl c
)))))
918 (defun class-has-a-cpl-protocol-violation-p (class)
919 (labels ((find-in-superclasses (class classes
)
922 ((eql class
(car classes
)) t
)
923 (t (find-in-superclasses class
(append (class-direct-superclasses (car classes
)) (cdr classes
)))))))
924 (let ((metaclass (class-of class
)))
926 ((eql metaclass
*the-class-standard-class
*)
927 (find-in-superclasses (find-class 'function
) (list class
)))
928 ((eql metaclass
*the-class-funcallable-standard-class
*)
929 (not (find-in-superclasses (find-class 'function
) (list class
))))))))
931 (defun %update-cpl
(class cpl
)
932 (when (eq (class-of class
) *the-class-standard-class
*)
933 (when (find (find-class 'function
) cpl
)
934 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
935 (when (eq (class-of class
) *the-class-funcallable-standard-class
*)
936 (unless (find (find-class 'function
) cpl
)
937 (error 'cpl-protocol-violation
:class class
:cpl cpl
)))
938 (if (class-finalized-p class
)
939 (unless (and (equal (class-precedence-list class
) cpl
)
941 (when (position :class
(class-direct-slots c
)
942 :key
#'slot-definition-allocation
)
944 ;; comment from the old CMU CL sources:
945 ;; Need to have the cpl setup before %update-lisp-class-layout
946 ;; is called on CMU CL.
947 (setf (slot-value class
'%class-precedence-list
) cpl
)
948 (setf (slot-value class
'cpl-available-p
) t
)
949 (%force-cache-flushes class
))
951 (setf (slot-value class
'%class-precedence-list
) cpl
)
952 (setf (slot-value class
'cpl-available-p
) t
)))
953 (update-class-can-precede-p cpl
))
955 (defun update-class-can-precede-p (cpl)
957 (let ((first (car cpl
)))
958 (dolist (c (cdr cpl
))
959 (pushnew c
(slot-value first
'can-precede-list
) :test
#'eq
)))
960 (update-class-can-precede-p (cdr cpl
))))
962 (defun class-can-precede-p (class1 class2
)
963 (member class2
(class-can-precede-list class1
) :test
#'eq
))
965 ;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible.
967 ;;; In addition to slot locations (implicit in the ordering of the slots), we
968 ;;; must check classes: SLOT-INFO structures from old slotds may have been
969 ;;; cached in permutation vectors, but new slotds have had new ones allocated
970 ;;; to them. This is non-problematic for standard slotds, because we know the
971 ;;; structure is compatible, but if a slot definition class changes, this can
972 ;;; change the way SLOT-VALUE-USING-CLASS should dispatch.
974 ;;; Also, if the slot has a non-standard allocation, we need to check that it
976 (defun slot-layouts-compatible-p
977 (oslotds new-instance-slotds new-class-slotds new-custom-slotds
)
978 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds
)
979 (classify-slotds oslotds
)
981 ;; Instance slots: name, type, and class.
982 (dolist (o old-instance-slotds
(not new-instance-slotds
))
983 (let ((n (pop new-instance-slotds
)))
985 (eq (slot-definition-name o
) (slot-definition-name n
))
986 (eq (slot-definition-type o
) (slot-definition-type n
))
987 (eq (class-of o
) (class-of n
)))
989 ;; Class slots: name and class. (FIXME: class slots not typechecked?)
990 (dolist (o old-class-slotds
(not new-class-slotds
))
991 (let ((n (pop new-class-slotds
)))
993 (eq (slot-definition-name o
) (slot-definition-name n
))
994 (eq (class-of n
) (class-of o
)))
996 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?)
997 (dolist (o old-custom-slotds
(not new-custom-slotds
))
998 (let ((n (pop new-custom-slotds
)))
1000 (eq (slot-definition-name o
) (slot-definition-name n
))
1001 (eq (slot-definition-type o
) (slot-definition-type n
))
1002 (eq (slot-definition-allocation o
) (slot-definition-allocation n
))
1003 (eq (class-of o
) (class-of n
)))
1006 (defun style-warn-about-duplicate-slots (class)
1007 (do* ((slots (slot-value class
'slots
) (cdr slots
))
1012 "~@<slot names with the same SYMBOL-NAME but ~
1013 different SYMBOL-PACKAGE (possible package problem) ~
1014 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>"
1016 (let* ((slot-name (slot-definition-name (car slots
)))
1017 (oslots (and (not (eq (symbol-package slot-name
)
1020 (lambda (slot-name-2)
1021 (or (eq (symbol-package slot-name-2
)
1023 (string/= slot-name slot-name-2
)))
1025 :key
#'slot-definition-name
))))
1027 (pushnew (cons slot-name
1028 (mapcar #'slot-definition-name oslots
))
1030 :test
#'string
= :key
#'car
)))))
1032 (defun %update-slots
(class eslotds
)
1033 (multiple-value-bind (instance-slots class-slots custom-slots
)
1034 (classify-slotds eslotds
)
1035 (let* ((nslots (length instance-slots
))
1036 (owrapper (when (class-finalized-p class
) (class-wrapper class
)))
1038 (cond ((null owrapper
)
1039 (make-wrapper nslots class
))
1040 ((slot-layouts-compatible-p (layout-slot-list owrapper
)
1041 instance-slots class-slots custom-slots
)
1044 ;; This will initialize the new wrapper to have the
1045 ;; same state as the old wrapper. We will then have
1046 ;; to change that. This may seem like wasted work
1047 ;; (and it is), but the spec requires that we call
1048 ;; MAKE-INSTANCES-OBSOLETE.
1049 (make-instances-obsolete class
)
1050 (class-wrapper class
)))))
1051 (%update-lisp-class-layout class nwrapper
)
1052 (setf (slot-value class
'slots
) eslotds
1053 (layout-slot-list nwrapper
) eslotds
1054 (layout-slot-table nwrapper
) (make-slot-table class eslotds
)
1055 (layout-length nwrapper
) nslots
1056 (slot-value class
'wrapper
) nwrapper
)
1057 (style-warn-about-duplicate-slots class
)
1058 (setf (slot-value class
'finalized-p
) t
)
1059 (unless (eq owrapper nwrapper
)
1060 (maybe-update-standard-slot-locations class
)))))
1062 (defun update-gf-dfun (class gf
)
1063 (let ((*new-class
* class
)
1064 (arg-info (gf-arg-info gf
)))
1066 ((special-case-for-compute-discriminating-function-p gf
))
1067 ((gf-precompute-dfun-and-emf-p arg-info
)
1068 (multiple-value-bind (dfun cache info
) (make-final-dfun-internal gf
)
1069 (update-dfun gf dfun cache info
))))))
1071 (defun update-gfs-of-class (class)
1072 (when (and (class-finalized-p class
)
1073 (let ((cpl (class-precedence-list class
)))
1074 (or (member *the-class-slot-class
* cpl
:test
#'eq
)
1075 (member *the-class-standard-effective-slot-definition
*
1077 (let ((gf-table (make-hash-table :test
'eq
)))
1078 (labels ((collect-gfs (class)
1079 (dolist (gf (specializer-direct-generic-functions class
))
1080 (setf (gethash gf gf-table
) t
))
1081 (mapc #'collect-gfs
(class-direct-superclasses class
))))
1083 (maphash (lambda (gf ignore
)
1084 (declare (ignore ignore
))
1085 (update-gf-dfun class gf
))
1088 (defmethod compute-default-initargs ((class slot-class
))
1089 (let ((initargs (loop for c in
(class-precedence-list class
)
1090 append
(class-direct-default-initargs c
))))
1091 (delete-duplicates initargs
:test
#'eq
:key
#'car
:from-end t
)))
1093 ;;;; protocols for constructing direct and effective slot definitions
1095 (defmethod direct-slot-definition-class ((class std-class
) &rest initargs
)
1096 (declare (ignore initargs
))
1097 (find-class 'standard-direct-slot-definition
))
1099 (defun make-direct-slotd (class initargs
)
1100 (apply #'make-instance
1101 (apply #'direct-slot-definition-class class initargs
)
1105 ;;; I (CSR) am not sure, but I believe that the particular order of
1106 ;;; slots is quite important: it is ideal to attempt to have a
1107 ;;; constant slot location for the same notional slots as much as
1108 ;;; possible, so that clever discriminating functions (ONE-INDEX et
1109 ;;; al.) have a chance of working. The below at least walks through
1110 ;;; the slots predictably, but maybe it would be good to compute some
1111 ;;; kind of optimal slot layout by looking at locations of slots in
1113 (defun std-compute-slots (class)
1114 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
1115 ;; for each different slot name we find in our superclasses. Each
1116 ;; call receives the class and a list of the dslotds with that name.
1117 ;; The list is in most-specific-first order.
1118 (let ((name-dslotds-alist ()))
1119 (dolist (c (reverse (class-precedence-list class
)))
1120 (dolist (slot (class-direct-slots c
))
1121 (let* ((name (slot-definition-name slot
))
1122 (entry (assq name name-dslotds-alist
)))
1124 (push slot
(cdr entry
))
1125 (push (list name slot
) name-dslotds-alist
)))))
1126 (mapcar (lambda (direct)
1127 (compute-effective-slot-definition class
1130 (nreverse name-dslotds-alist
))))
1132 ;; It seems to me that this should be one method defined on SLOT-CLASS.
1133 (defmethod compute-slots ((class standard-class
))
1134 (std-compute-slots class
))
1135 (defmethod compute-slots ((class funcallable-standard-class
))
1136 (std-compute-slots class
))
1137 (defmethod compute-slots ((class structure-class
))
1138 (std-compute-slots class
))
1139 (defmethod compute-slots ((class condition-class
))
1140 (std-compute-slots class
))
1142 (defun std-compute-slots-around (class eslotds
)
1144 (safe (safe-p class
)))
1145 (dolist (eslotd eslotds eslotds
)
1146 (setf (slot-definition-location eslotd
)
1147 (case (slot-definition-allocation eslotd
)
1151 (let* ((name (slot-definition-name eslotd
))
1154 (slot-definition-allocation-class eslotd
)
1155 ;; we get here if the user adds an extra slot
1157 (setf (slot-definition-allocation-class eslotd
)
1159 ;; which raises the question of what we should
1160 ;; do if we find that said user has added a slot
1161 ;; with the same name as another slot...
1162 (cell (or (assq name
(class-slot-cells from-class
))
1163 (let ((c (cons name
+slot-unbound
+)))
1164 (push c
(class-slot-cells from-class
))
1167 (if (eq +slot-unbound
+ (cdr cell
))
1168 ;; We may have inherited an initfunction FIXME: Is this
1169 ;; really right? Is the initialization in
1170 ;; SHARED-INITIALIZE (STD-CLASS) not enough?
1171 (let ((initfun (slot-definition-initfunction eslotd
)))
1173 (rplacd cell
(call-initfun initfun eslotd safe
))
1176 (unless (slot-definition-class eslotd
)
1177 (setf (slot-definition-class eslotd
) class
))
1178 (initialize-internal-slot-functions eslotd
))))
1180 (defmethod compute-slots :around
((class standard-class
))
1181 (let ((eslotds (call-next-method)))
1182 (std-compute-slots-around class eslotds
)))
1183 (defmethod compute-slots :around
((class funcallable-standard-class
))
1184 (let ((eslotds (call-next-method)))
1185 (std-compute-slots-around class eslotds
)))
1186 (defmethod compute-slots :around
((class structure-class
))
1187 (let ((eslotds (call-next-method)))
1188 (mapc #'finalize-internal-slot-functions eslotds
)
1191 (defmethod compute-effective-slot-definition ((class slot-class
) name dslotds
)
1192 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds
))
1193 (class (apply #'effective-slot-definition-class class initargs
))
1194 (slotd (apply #'make-instance class initargs
)))
1197 (defmethod effective-slot-definition-class ((class std-class
) &rest initargs
)
1198 (declare (ignore initargs
))
1199 (find-class 'standard-effective-slot-definition
))
1201 (defmethod effective-slot-definition-class ((class structure-class
) &rest initargs
)
1202 (declare (ignore initargs
))
1203 (find-class 'structure-effective-slot-definition
))
1205 (defmethod compute-effective-slot-definition-initargs
1206 ((class slot-class
) direct-slotds
)
1212 (allocation-class nil
)
1215 (documentationp nil
)
1220 (dolist (slotd direct-slotds
)
1223 (setq name
(slot-definition-name slotd
)
1226 (awhen (slot-definition-initfunction slotd
)
1227 (setq initform
(slot-definition-initform slotd
)
1230 (unless documentationp
1231 (awhen (%slot-definition-documentation slotd
)
1232 (setq documentation it
1235 (setq allocation
(slot-definition-allocation slotd
)
1236 allocation-class
(slot-definition-class slotd
)
1238 (setq initargs
(append (slot-definition-initargs slotd
) initargs
))
1239 (let ((slotd-type (slot-definition-type slotd
)))
1241 ((eq type t
) slotd-type
)
1242 ;; This pairwise type intersection is perhaps a
1243 ;; little inefficient and inelegant, but it's
1244 ;; unlikely to lie on the critical path. Shout
1245 ;; if I'm wrong. -- CSR, 2005-11-24
1247 (specifier-type `(and ,type
,slotd-type
)))))))))
1250 :initfunction initfunction
1252 :allocation allocation
1253 :allocation-class allocation-class
1256 :documentation documentation
)))
1258 (defmethod compute-effective-slot-definition-initargs :around
1259 ((class structure-class
) direct-slotds
)
1260 (let* ((slotd (car direct-slotds
))
1261 (accessor (slot-definition-defstruct-accessor-symbol slotd
)))
1262 (list* :defstruct-accessor-symbol accessor
1263 :internal-reader-function
1264 (slot-definition-internal-reader-function slotd
)
1265 :internal-writer-function
1266 (slot-definition-internal-writer-function slotd
)
1267 (call-next-method))))
1269 ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
1270 ;;; to make the method object. They have to use make-a-method which
1271 ;;; is a specially bootstrapped mechanism for making standard methods.
1272 (defmethod reader-method-class ((class slot-class
) direct-slot
&rest initargs
)
1273 (declare (ignore direct-slot initargs
))
1274 (find-class 'standard-reader-method
))
1276 (defmethod add-reader-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1277 (add-method generic-function
1278 (make-a-method 'standard-reader-method
1280 (list (or (class-name class
) 'object
))
1282 (make-reader-method-function class slot-name
)
1283 (or slot-documentation
"automatically generated reader method")
1284 :slot-name slot-name
1286 :method-class-function
#'reader-method-class
1287 :definition-source source-location
)))
1289 (defmethod writer-method-class ((class slot-class
) direct-slot
&rest initargs
)
1290 (declare (ignore direct-slot initargs
))
1291 (find-class 'standard-writer-method
))
1293 (defmethod add-writer-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1294 (add-method generic-function
1295 (make-a-method 'standard-writer-method
1297 (list 'new-value
(or (class-name class
) 'object
))
1298 (list *the-class-t
* class
)
1299 (make-writer-method-function class slot-name
)
1300 (or slot-documentation
"automatically generated writer method")
1301 :slot-name slot-name
1303 :method-class-function
#'writer-method-class
1304 :definition-source source-location
)))
1306 (defmethod add-boundp-method ((class slot-class
) generic-function slot-name slot-documentation source-location
)
1307 (add-method generic-function
1308 (make-a-method (constantly (find-class 'standard-boundp-method
))
1311 (list (or (class-name class
) 'object
))
1313 (make-boundp-method-function class slot-name
)
1314 (or slot-documentation
"automatically generated boundp method")
1315 :slot-name slot-name
1316 :definition-source source-location
)))
1318 (defmethod remove-reader-method ((class slot-class
) generic-function
)
1319 (let ((method (get-method generic-function
() (list class
) nil
)))
1320 (when method
(remove-method generic-function method
))))
1322 (defmethod remove-writer-method ((class slot-class
) generic-function
)
1324 (get-method generic-function
() (list *the-class-t
* class
) nil
)))
1325 (when method
(remove-method generic-function method
))))
1327 (defmethod remove-boundp-method ((class slot-class
) generic-function
)
1328 (let ((method (get-method generic-function
() (list class
) nil
)))
1329 (when method
(remove-method generic-function method
))))
1331 ;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION
1332 ;;; function are NOT part of the standard protocol. They are however
1333 ;;; useful; PCL makes use of them internally and documents them for
1334 ;;; PCL users. (FIXME: but SBCL certainly doesn't)
1336 ;;; *** This needs work to make type testing by the writer functions which
1337 ;;; *** do type testing faster. The idea would be to have one constructor
1338 ;;; *** for each possible type test.
1340 ;;; *** There is a subtle bug here which is going to have to be fixed.
1341 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1342 ;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have
1343 ;;; *** defined for this metaclass a chance to run.
1345 (defmethod make-reader-method-function ((class slot-class
) slot-name
)
1346 (make-std-reader-method-function class slot-name
))
1348 (defmethod make-writer-method-function ((class slot-class
) slot-name
)
1349 (make-std-writer-method-function class slot-name
))
1351 (defmethod make-boundp-method-function ((class slot-class
) slot-name
)
1352 (make-std-boundp-method-function class slot-name
))
1354 (defmethod compatible-meta-class-change-p (class proto-new-class
)
1355 (eq (class-of class
) (class-of proto-new-class
)))
1357 (defmethod validate-superclass ((class class
) (superclass class
))
1358 (or (eq (class-of class
) (class-of superclass
))
1359 (and (eq (class-of superclass
) *the-class-standard-class
*)
1360 (eq (class-of class
) *the-class-funcallable-standard-class
*))
1361 (and (eq (class-of superclass
) *the-class-funcallable-standard-class
*)
1362 (eq (class-of class
) *the-class-standard-class
*))))
1364 ;;; What this does depends on which of the four possible values of
1365 ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
1366 ;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
1367 ;;; nothing to do, as the new wrapper has already been created. If
1368 ;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
1369 ;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
1370 ;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
1372 ;;; This leaves the case where LAYOUT-INVALID returns T, which happens
1373 ;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
1374 ;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
1375 ;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
1376 ;;; obsolete the wrapper.
1378 ;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
1379 ;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
1380 ;;; :UNINITIALIZED)))
1382 ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
1383 (defun %force-cache-flushes
(class)
1385 (let* ((owrapper (class-wrapper class
)))
1386 ;; We only need to do something if the wrapper is still valid. If
1387 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and
1388 ;; both of those will already be doing what we want. In
1389 ;; particular, we must be sure we never change an OBSOLETE into a
1390 ;; FLUSH since OBSOLETE means do what FLUSH does and then some.
1391 (when (or (not (invalid-wrapper-p owrapper
))
1392 ;; KLUDGE: despite the observations above, this remains
1393 ;; a violation of locality or what might be considered
1394 ;; good style. There has to be a better way! -- CSR,
1396 (eq (layout-invalid owrapper
) t
))
1397 (let ((nwrapper (make-wrapper (layout-length owrapper
)
1399 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1400 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1401 (%update-lisp-class-layout class nwrapper
)
1402 (setf (slot-value class
'wrapper
) nwrapper
)
1403 ;; Use :OBSOLETE instead of :FLUSH if any superclass has
1405 (if (find-if (lambda (x)
1406 (and (consp x
) (eq :obsolete
(car x
))))
1407 (layout-inherits owrapper
)
1408 :key
#'layout-invalid
)
1409 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1410 (%invalidate-wrapper owrapper
:flush nwrapper
))))))
1413 ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause
1414 ;;; the next access to the instance (as defined in 88-002R) to trap
1415 ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
1416 (defmethod make-instances-obsolete ((class std-class
))
1418 (let* ((owrapper (class-wrapper class
))
1419 (nwrapper (make-wrapper (layout-length owrapper
)
1421 (unless (class-finalized-p class
)
1422 (if (class-has-a-forward-referenced-superclass-p class
)
1423 (return-from make-instances-obsolete class
)
1424 (%update-cpl class
(compute-class-precedence-list class
))))
1425 (setf (layout-slot-list nwrapper
) (layout-slot-list owrapper
))
1426 (setf (layout-slot-table nwrapper
) (layout-slot-table owrapper
))
1427 (%update-lisp-class-layout class nwrapper
)
1428 (setf (slot-value class
'wrapper
) nwrapper
)
1429 (%invalidate-wrapper owrapper
:obsolete nwrapper
)
1432 (defmethod make-instances-obsolete ((class symbol
))
1433 (make-instances-obsolete (find-class class
))
1434 ;; ANSI wants the class name when called with a symbol.
1437 ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we
1438 ;;; see an obsolete instance. The times when it is called are:
1439 ;;; - when the instance is involved in method lookup
1440 ;;; - when attempting to access a slot of an instance
1442 ;;; It is not called by class-of, wrapper-of, or any of the low-level
1443 ;;; instance access macros.
1445 ;;; Of course these times when it is called are an internal
1446 ;;; implementation detail of PCL and are not part of the documented
1447 ;;; description of when the obsolete instance update happens. The
1448 ;;; documented description is as it appears in 88-002R.
1450 ;;; This has to return the new wrapper, so it counts on all the
1451 ;;; methods on obsolete-instance-trap-internal to return the new
1452 ;;; wrapper. It also does a little internal error checking to make
1453 ;;; sure that the traps are only happening when they should, and that
1454 ;;; the trap methods are computing appropriate new wrappers.
1456 ;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances
1457 ;;; after a structure is redefined. In most cases,
1458 ;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance,
1459 ;;; so it must signal an error. The hard part of this is that the
1460 ;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be
1461 ;;; called again, so in that case, we have to return some reasonable
1462 ;;; wrapper, instead.
1464 (defun %ensure-slot-value-type
(context slot-name slot-type value
1465 old-class new-class
)
1466 (do () ((typep value slot-type
))
1468 (bad-type value slot-type
1469 "~@<Error during ~A. Current value in slot ~
1470 ~/sb-impl::print-symbol-with-prefix/ of an instance ~
1471 of ~S is ~S, which does not match the new slot type ~
1472 ~S in class ~S.~:@>"
1473 context slot-name old-class value slot-type new-class
)
1474 (use-value (new-value)
1475 :interactive read-evaluated-form
1476 :report
(lambda (stream)
1477 (format stream
"~@<Specify a new value to by used ~
1479 ~/sb-impl::print-symbol-with-prefix/ ~
1482 (setf value new-value
))))
1485 (defun %set-slot-value-checking-type
(context slots slot value
1486 safe old-class new-class
)
1487 (setf (clos-slots-ref slots
(slot-definition-location slot
))
1488 (if (and safe
(neq value
+slot-unbound
+))
1489 (let ((name (slot-definition-name slot
))
1490 (type (slot-definition-type slot
)))
1491 (%ensure-slot-value-type context name type value
1492 old-class new-class
))
1495 (defvar *in-obsolete-instance-trap
* nil
)
1496 (defvar *the-wrapper-of-structure-object
*
1497 (class-wrapper (find-class 'structure-object
)))
1499 (define-condition obsolete-structure
(error)
1500 ((datum :reader obsolete-structure-datum
:initarg
:datum
))
1502 (lambda (condition stream
)
1503 ;; Don't try to print the structure, since it probably won't work.
1505 "~@<obsolete structure error for a structure of type ~2I~_~S~:>"
1506 (type-of (obsolete-structure-datum condition
))))))
1508 (defun %obsolete-instance-trap
(owrapper nwrapper instance
)
1510 ((layout-for-std-class-p owrapper
)
1511 (binding* ((class (wrapper-class* nwrapper
))
1512 (copy (allocate-instance class
)) ;??? allocate-instance ???
1513 (oslots (get-slots instance
))
1514 (nslots (get-slots copy
))
1518 (safe (safe-p class
))
1519 ((new-instance-slots nil new-custom-slots
)
1520 (classify-slotds (layout-slot-list nwrapper
)))
1521 ((old-instance-slots old-class-slots old-custom-slots
)
1522 (classify-slotds (layout-slot-list owrapper
)))
1523 (layout (mapcar (lambda (slotd)
1524 ;; Get the names only once.
1525 (cons (slot-definition-name slotd
) slotd
))
1526 new-instance-slots
)))
1527 ;; local --> local transfer value, check type
1528 ;; local --> shared discard value, discard slot
1529 ;; local --> -- discard slot
1530 ;; local --> custom XXX
1532 ;; shared --> local transfer value, check type
1533 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
1534 ;; shared --> -- discard value
1535 ;; shared --> custom XXX
1537 ;; -- --> local add slot
1539 ;; -- --> custom XXX
1540 (flet ((set-value (value cell
)
1541 (%set-slot-value-checking-type
1542 "updating obsolete instance"
1543 nslots
(cdr cell
) value safe class class
)
1544 ;; Prune from the list now that it's been dealt with.
1545 (setf layout
(remove cell layout
))))
1547 ;; Go through all the old local slots.
1548 (dolist (old old-instance-slots
)
1549 (let* ((name (slot-definition-name old
))
1550 (value (clos-slots-ref oslots
(slot-definition-location old
))))
1551 (unless (eq value
+slot-unbound
+)
1552 (let ((new (assq name layout
)))
1554 (set-value value new
))
1556 (push name discarded
)
1557 (setf (getf plist name
) value
)))))))
1559 ;; Go through all the old shared slots.
1560 (dolist (old old-class-slots
)
1561 (binding* ((cell (slot-definition-location old
))
1563 (new (assq name layout
) :exit-if-null
))
1564 (set-value (cdr cell
) new
)))
1566 ;; Go through all custom slots to find added ones. CLHS
1567 ;; doesn't specify what to do about them, and neither does
1568 ;; AMOP. We do want them to get initialized, though, so we
1569 ;; list them in ADDED for the benefit of SHARED-INITIALIZE.
1570 (dolist (new new-custom-slots
)
1571 (let* ((name (slot-definition-name new
))
1572 (old (find name old-custom-slots
1573 :key
#'slot-definition-name
)))
1575 (push name added
))))
1577 ;; Go through all the remaining new local slots to compute
1579 (dolist (cell layout
)
1580 (push (car cell
) added
)))
1582 (%swap-wrappers-and-slots instance copy
)
1584 (update-instance-for-redefined-class
1585 instance added discarded plist
)
1588 (*in-obsolete-instance-trap
*
1589 *the-wrapper-of-structure-object
*)
1591 (let ((*in-obsolete-instance-trap
* t
))
1592 (error 'obsolete-structure
:datum instance
)))))
1595 (defun %change-class
(instance new-class initargs
)
1596 (binding* ((old-class (class-of instance
))
1597 (copy (allocate-instance new-class
))
1598 (new-wrapper (get-wrapper copy
))
1599 (old-wrapper (class-wrapper old-class
))
1600 (old-slots (get-slots instance
))
1601 (new-slots (get-slots copy
))
1602 (safe (safe-p new-class
))
1604 (classify-slotds (layout-slot-list new-wrapper
)))
1605 ((old-instance-slots old-class-slots
)
1606 (classify-slotds (layout-slot-list old-wrapper
))))
1607 (labels ((find-slot (name slots
)
1608 (find name slots
:key
#'slot-definition-name
))
1609 (initarg-for-slot-p (slot)
1610 (dolist (slot-initarg (slot-definition-initargs slot
))
1611 ;; Abuse +slot-unbound+
1612 (unless (eq +slot-unbound
+
1613 (getf initargs slot-initarg
+slot-unbound
+))
1615 (set-value (value slotd
)
1616 (%set-slot-value-checking-type
1617 'change-class new-slots slotd value safe
1618 old-class new-class
)))
1620 ;; "The values of local slots specified by both the class CTO
1621 ;; and CFROM are retained. If such a local slot was unbound, it
1622 ;; remains unbound."
1623 (dolist (new new-instance-slots
)
1624 (unless (initarg-for-slot-p new
)
1625 (binding* ((old (find-slot (slot-definition-name new
) old-instance-slots
)
1627 (value (clos-slots-ref old-slots
(slot-definition-location old
))))
1628 (set-value value new
))))
1630 ;; "The values of slots specified as shared in the class CFROM and
1631 ;; as local in the class CTO are retained."
1632 (dolist (old old-class-slots
)
1633 (binding* ((slot-and-val (slot-definition-location old
))
1634 (new (find-slot (car slot-and-val
) new-instance-slots
)
1636 (set-value (cdr slot-and-val
) new
))))
1638 ;; Make the copy point to the old instance's storage, and make the
1639 ;; old instance point to the new storage.
1640 (%swap-wrappers-and-slots instance copy
)
1642 (apply #'update-instance-for-different-class copy instance initargs
)
1646 (defun check-new-class-not-metaobject (new-class)
1647 (dolist (class (class-precedence-list
1648 (ensure-class-finalized new-class
)))
1650 ((check-metaobject (class-name)
1651 `(when (eq class
(find-class ',class-name
))
1652 (change-class-to-metaobject-violation
1653 ',class-name nil
'((:amop
:initialization
,class-name
))))))
1654 (check-metaobject class
)
1655 (check-metaobject generic-function
)
1656 (check-metaobject method
)
1657 (check-metaobject slot-definition
))))
1659 (defmethod change-class ((instance standard-object
) (new-class standard-class
)
1662 (check-new-class-not-metaobject new-class
)
1663 (%change-class instance new-class initargs
)))
1665 (defmethod change-class ((instance forward-referenced-class
)
1666 (new-class standard-class
) &rest initargs
)
1668 (dolist (class (class-precedence-list
1669 (ensure-class-finalized new-class
))
1670 (change-class-to-metaobject-violation
1671 '(not class
) 'forward-referenced-class
1672 '((:amop
:generic-function ensure-class-using-class
)
1673 (:amop
:initialization class
))))
1674 (when (eq class
(find-class 'class
))
1676 (%change-class instance new-class initargs
)))
1678 (defmethod change-class ((instance t
)
1679 (new-class forward-referenced-class
) &rest initargs
)
1680 (declare (ignore initargs
))
1681 (change-class-to-metaobject-violation
1682 'forward-referenced-class nil
1683 '((:amop
:generic-function ensure-class-using-class
)
1684 (:amop
:initialization class
))))
1686 (defmethod change-class ((instance funcallable-standard-object
)
1687 (new-class funcallable-standard-class
)
1690 (check-new-class-not-metaobject new-class
)
1691 (%change-class instance new-class initargs
)))
1693 (defmethod change-class ((instance standard-object
)
1694 (new-class funcallable-standard-class
)
1696 (declare (ignore initargs
))
1697 (error "You can't change the class of ~S to ~S~@
1698 because it isn't already an instance with metaclass ~S."
1699 instance new-class
'standard-class
))
1701 (defmethod change-class ((instance funcallable-standard-object
)
1702 (new-class standard-class
)
1704 (declare (ignore initargs
))
1705 (error "You can't change the class of ~S to ~S~@
1706 because it isn't already an instance with metaclass ~S."
1707 instance new-class
'funcallable-standard-class
))
1709 (defmethod change-class ((instance t
) (new-class-name symbol
) &rest initargs
)
1710 (apply #'change-class instance
(find-class new-class-name
) initargs
))
1712 ;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS
1714 ;;;; These metaclasses are something of a weird creature. By this
1715 ;;;; point, all instances which will exist have been created, and no
1716 ;;;; instance is ever created by calling MAKE-INSTANCE. (The
1717 ;;;; distinction between the metaclasses is that we allow subclassing
1718 ;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols,
1719 ;;;; but not of BUILT-IN-CLASS.)
1721 ;;;; AMOP mandates some behaviour of the implementation with respect
1722 ;;;; to BUILT-IN-CLASSes, and we implement that through methods on
1723 ;;;; SYSTEM-CLASS here.
1725 (macrolet ((def (name args control
)
1726 `(defmethod ,name
,args
1727 (declare (ignore initargs
))
1728 (error 'metaobject-initialization-violation
1729 :format-control
,(format nil
"~@<~A~@:>" control
)
1730 :format-arguments
(list (class-name class
))
1731 :references
(list '(:amop
:initialization
"Class"))))))
1732 (def initialize-instance
((class system-class
) &rest initargs
)
1733 "Cannot initialize an instance of ~S.")
1734 (def reinitialize-instance
((class system-class
) &rest initargs
)
1735 "Cannot reinitialize an instance of ~S."))
1737 (macrolet ((def (name) `(defmethod ,name
((class system-class
)) nil
)))
1738 (def class-direct-slots
)
1740 (def class-direct-default-initargs
)
1741 (def class-default-initargs
))
1743 (defmethod validate-superclass ((c class
) (s system-class
))
1745 (defmethod validate-superclass ((c class
) (s built-in-class
))
1748 ;;; Some necessary methods for FORWARD-REFERENCED-CLASS
1749 (defmethod class-direct-slots ((class forward-referenced-class
)) ())
1750 (defmethod class-direct-default-initargs ((class forward-referenced-class
)) ())
1751 (macrolet ((def (method)
1752 `(defmethod ,method
((class forward-referenced-class
))
1753 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>"
1755 (def class-default-initargs
)
1756 (def class-precedence-list
)
1759 (defmethod validate-superclass ((c slot-class
) (f forward-referenced-class
))
1762 (defmethod add-dependent ((metaobject dependent-update-mixin
) dependent
)
1763 (pushnew dependent
(plist-value metaobject
'dependents
) :test
#'eq
))
1765 (defmethod remove-dependent ((metaobject dependent-update-mixin
) dependent
)
1766 (setf (plist-value metaobject
'dependents
)
1767 (delete dependent
(plist-value metaobject
'dependents
))))
1769 (defmethod map-dependents ((metaobject dependent-update-mixin
) function
)
1770 (dolist (dependent (plist-value metaobject
'dependents
))
1771 (funcall function dependent
)))