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