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 ;;;; ANSI CL condition for unbound slots
28 (define-condition unbound-slot
(cell-error)
29 ((instance :reader unbound-slot-instance
:initarg
:instance
))
30 (:report
(lambda (condition stream
)
32 (format stream
"~@<The slot ~/sb-ext:print-symbol-with-prefix/ ~
33 is unbound in the object ~A.~@:>"
34 (cell-error-name condition
)
35 (unbound-slot-instance condition
))
37 ;; In case of an error try again avoiding custom PRINT-OBJECT's.
38 (format stream
"~&Error during printing.~%~@<The slot ~
39 ~/sb-ext:print-symbol-with-prefix/ ~
40 is unbound in an instance of ~
41 ~/sb-ext:print-symbol-with-prefix/.~@:>"
42 (cell-error-name condition
)
43 (type-of (unbound-slot-instance condition
))))))))
45 (defmethod wrapper-fetcher ((class standard-class
))
48 (defmethod slots-fetcher ((class standard-class
))
51 (defmethod raw-instance-allocator ((class standard-class
))
52 'allocate-standard-instance
)
54 ;;; These three functions work on std-instances and fsc-instances. These are
55 ;;; instances for which it is possible to change the wrapper and the slots.
57 ;;; For these kinds of instances, most specified methods from the instance
58 ;;; structure protocol are promoted to the implementation-specific class
59 ;;; std-class. Many of these methods call these four functions.
61 (defun %swap-wrappers-and-slots
(i1 i2
) ; old -> new
62 (cond ((std-instance-p i1
)
63 #+(and compact-instance-header x86-64
)
64 (let ((oslots (std-instance-slots i1
))
65 (nslots (std-instance-slots i2
)))
66 ;; The hash val is in the header of the slots. Copying is race-free
67 ;; because it is immutable once memoized by STD-INSTANCE-HASH.
68 (sb-vm::cas-header-data-high
69 nslots
0 (sb-impl::%std-instance-hash oslots
)))
70 ;; FIXME: If a backend supports two-word primitive instances
71 ;; and double-wide CAS, it's probably best to use that.
72 ;; Maybe we're inside a mutex here anyway though?
73 (let ((w1 (%instance-layout i1
))
74 (s1 (std-instance-slots i1
)))
75 (setf (%instance-layout i1
) (%instance-layout i2
))
76 (setf (std-instance-slots i1
) (std-instance-slots i2
))
77 (setf (%instance-layout i2
) w1
)
78 (setf (std-instance-slots i2
) s1
)))
80 (let ((w1 (%funcallable-instance-layout i1
))
81 (w2 (%funcallable-instance-layout i2
))
82 (s1 (fsc-instance-slots i1
)))
83 (aver (= (layout-bitmap w1
) (layout-bitmap w2
)))
84 (setf (%funcallable-instance-layout i1
) w2
)
85 (setf (fsc-instance-slots i1
) (fsc-instance-slots i2
))
86 (setf (%funcallable-instance-layout i2
) w1
)
87 (setf (fsc-instance-slots i2
) s1
)))
89 (error "unrecognized instance type"))))
91 ;;;; STANDARD-INSTANCE-ACCESS
93 (declaim (inline standard-instance-access
94 (setf standard-instance-access
)
95 (cas stadard-instance-access
)
96 funcallable-standard-instance-access
97 (setf funcallable-standard-instance-access
)
98 (cas funcallable-standard-instance-access
)))
100 (defun standard-instance-access (instance location
)
101 (clos-slots-ref (std-instance-slots instance
) location
))
103 (defun (setf standard-instance-access
) (new-value instance location
)
104 (setf (clos-slots-ref (std-instance-slots instance
) location
) new-value
))
106 (defun (cas standard-instance-access
) (old-value new-value instance location
)
107 ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
108 (cas (svref (std-instance-slots instance
) location
) old-value new-value
))
110 (defun funcallable-standard-instance-access (instance location
)
111 (clos-slots-ref (fsc-instance-slots instance
) location
))
113 (defun (setf funcallable-standard-instance-access
) (new-value instance location
)
114 (setf (clos-slots-ref (fsc-instance-slots instance
) location
) new-value
))
116 (defun (cas funcallable-standard-instance-access
) (old-value new-value instance location
)
117 ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely?
118 (cas (svref (fsc-instance-slots instance
) location
) old-value new-value
))
120 ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
122 (declaim (ftype (sfunction (t symbol
) t
) slot-value
))
123 (defun slot-value (object slot-name
)
124 (let* ((wrapper (valid-wrapper-of object
))
125 (cell (find-slot-cell wrapper slot-name
))
126 (location (car cell
))
128 (cond ((fixnump location
)
129 (if (std-instance-p object
)
130 (standard-instance-access object location
)
131 (funcallable-standard-instance-access object location
)))
133 (return-from slot-value
135 (funcall (slot-info-reader (cdr cell
)) object
)
136 (values (slot-missing (wrapper-class* wrapper
) object
137 slot-name
'slot-value
)))))
138 ;; this next test means CONSP, but the transform that weakens
139 ;; CONSP to LISTP isn't working here for some reason.
143 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell
)))))
144 (if (eq +slot-unbound
+ value
)
145 (slot-unbound (wrapper-class* wrapper
) object slot-name
)
148 (defun set-slot-value (object slot-name new-value
)
149 (let* ((wrapper (valid-wrapper-of object
))
150 (cell (or (find-slot-cell wrapper slot-name
)
151 (return-from set-slot-value
152 (progn (slot-missing (wrapper-class* wrapper
)
153 object slot-name
'setf new-value
)
155 (location (car cell
))
157 (typecheck (slot-info-typecheck info
)))
159 (funcall typecheck new-value
))
160 (cond ((fixnump location
)
161 (if (std-instance-p object
)
162 (setf (standard-instance-access object location
) new-value
)
163 (setf (funcallable-standard-instance-access object location
)
166 (funcall (slot-info-writer info
) new-value object
))
167 ((listp location
) ; forcibly transform CONSP to LISTP
168 (setf (cdr location
) new-value
))
170 (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell
))))
173 ;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
174 ;;; check types when writing to slots:
175 ;;; * Doesn't have an optimizing compiler-macro
176 ;;; * Isn't special-cased in WALK-METHOD-LAMBDA
177 (defun safe-set-slot-value (object slot-name new-value
)
178 (set-slot-value object slot-name new-value
))
180 (defun (cas slot-value
) (old-value new-value object slot-name
)
181 (let* ((wrapper (valid-wrapper-of object
))
182 (cell (or (find-slot-cell wrapper slot-name
)
183 (return-from slot-value
184 (values (slot-missing (wrapper-class* wrapper
) object slot-name
185 'cas
(list old-value new-value
))))))
186 (location (car cell
))
188 (typecheck (slot-info-typecheck info
)))
190 (funcall typecheck new-value
))
191 (let ((old (cond ((fixnump location
)
192 (if (std-instance-p object
)
193 (cas (standard-instance-access object location
) old-value new-value
)
194 (cas (funcallable-standard-instance-access object location
)
195 old-value new-value
)))
197 ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)...
198 (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object
))
199 ((listp location
) ; forcibly transform CONSP to LISTP
200 (cas (cdr location
) old-value new-value
))
202 (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell
)))))
203 (if (and (eq +slot-unbound
+ old
)
205 (slot-unbound (wrapper-class* wrapper
) object slot-name
)
208 (defun slot-boundp (object slot-name
)
209 (let* ((wrapper (valid-wrapper-of object
))
210 (cell (find-slot-cell wrapper slot-name
))
211 (location (car cell
))
213 (cond ((fixnump location
)
214 (if (std-instance-p object
)
215 (standard-instance-access object location
)
216 (funcallable-standard-instance-access object location
)))
218 (return-from slot-boundp
220 (funcall (slot-info-boundp (cdr cell
)) object
)
221 (and (slot-missing (wrapper-class* wrapper
) object
222 slot-name
'slot-boundp
)
224 ((listp location
) ; forcibly transform CONSP to LISTP
227 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell
)))))
228 (not (eq +slot-unbound
+ value
))))
230 (defun slot-makunbound (object slot-name
)
231 (let* ((wrapper (valid-wrapper-of object
))
232 (cell (find-slot-cell wrapper slot-name
))
233 (location (car cell
)))
234 (cond ((fixnump location
)
235 (if (std-instance-p object
)
236 (setf (standard-instance-access object location
) +slot-unbound
+)
237 (setf (funcallable-standard-instance-access object location
)
241 (let ((class (wrapper-class* wrapper
)))
242 (slot-makunbound-using-class class object
243 (find-slot-definition class slot-name
)))
244 (slot-missing (wrapper-class* wrapper
) object slot-name
246 ((listp location
) ; forcibly transform CONSP to LISTP
247 (setf (cdr location
) +slot-unbound
+))
249 (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell
))))
252 ;; Note that CLHS "encourages" implementors to base this on
253 ;; SLOT-EXISTS-P-USING-CLASS, whereas 88-002R made no such claim,
254 ;; however Appendix D of AMOP sketches out such an implementation.
255 (defun slot-exists-p (object slot-name
)
256 (not (null (find-slot-cell (valid-wrapper-of object
) slot-name
))))
258 (defun slot-value-for-printing (object slot-name
)
259 (if (slot-boundp object slot-name
)
260 (slot-value object slot-name
)
261 (load-time-value (make-unprintable-object "unbound slot") t
)))
263 (defmethod slot-value-using-class ((class std-class
)
264 (object standard-object
)
265 (slotd standard-effective-slot-definition
))
266 ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
267 ;; instances. Are users allowed to call this directly?
268 (check-obsolete-instance object
)
269 (let* ((location (slot-definition-location slotd
))
273 (cond ((std-instance-p object
)
274 (clos-slots-ref (std-instance-slots object
)
276 ((fsc-instance-p object
)
277 (clos-slots-ref (fsc-instance-slots object
)
279 (t (bug "unrecognized instance type in ~S"
280 'slot-value-using-class
))))
284 (instance-structure-protocol-error slotd
285 'slot-value-using-class
)))))
286 (if (eq value
+slot-unbound
+)
287 (values (slot-unbound class object
(slot-definition-name slotd
)))
290 (defmethod (setf slot-value-using-class
)
291 (new-value (class std-class
)
292 (object standard-object
)
293 (slotd standard-effective-slot-definition
))
294 ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
295 ;; instances. Are users allowed to call this directly?
296 (check-obsolete-instance object
)
297 (let* ((info (slot-definition-info slotd
))
298 (location (slot-definition-location slotd
))
299 (typecheck (slot-info-typecheck info
))
300 (new-value (if typecheck
301 (funcall (the function typecheck
) new-value
)
305 (cond ((std-instance-p object
)
306 (setf (clos-slots-ref (std-instance-slots object
) location
)
308 ((fsc-instance-p object
)
309 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
311 (t (bug "unrecognized instance type in ~S"
312 '(setf slot-value-using-class
)))))
314 (setf (cdr location
) new-value
))
316 (instance-structure-protocol-error
317 slotd
'(setf slot-value-using-class
))))))
319 (defmethod slot-boundp-using-class
321 (object standard-object
)
322 (slotd standard-effective-slot-definition
))
323 ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
324 ;; instances. Are users allowed to call this directly?
325 (check-obsolete-instance object
)
326 (let* ((location (slot-definition-location slotd
))
330 (cond ((std-instance-p object
)
331 (clos-slots-ref (std-instance-slots object
)
333 ((fsc-instance-p object
)
334 (clos-slots-ref (fsc-instance-slots object
)
336 (t (bug "unrecognized instance type in ~S"
337 'slot-boundp-using-class
))))
341 (instance-structure-protocol-error slotd
342 'slot-boundp-using-class
)))))
343 (not (eq value
+slot-unbound
+))))
345 (defmethod slot-makunbound-using-class
347 (object standard-object
)
348 (slotd standard-effective-slot-definition
))
349 (check-obsolete-instance object
)
350 (let ((location (slot-definition-location slotd
)))
353 (cond ((std-instance-p object
)
354 (setf (clos-slots-ref (std-instance-slots object
) location
)
356 ((fsc-instance-p object
)
357 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
359 (t (bug "unrecognized instance type in ~S"
360 'slot-makunbound-using-class
))))
362 (setf (cdr location
) +slot-unbound
+))
364 (instance-structure-protocol-error slotd
365 'slot-makunbound-using-class
))))
368 (defmethod slot-value-using-class
369 ((class condition-class
)
371 (slotd condition-effective-slot-definition
))
372 (let ((fun (slot-info-reader (slot-definition-info slotd
))))
373 (funcall fun object
)))
375 (defmethod (setf slot-value-using-class
)
377 (class condition-class
)
379 (slotd condition-effective-slot-definition
))
380 (let ((fun (slot-info-writer (slot-definition-info slotd
))))
381 (funcall fun new-value object
)))
383 (defmethod slot-boundp-using-class
384 ((class condition-class
)
386 (slotd condition-effective-slot-definition
))
387 (let ((fun (slot-info-boundp (slot-definition-info slotd
))))
388 (funcall fun object
)))
390 (defmethod slot-makunbound-using-class ((class condition-class
) object slot
)
391 (error "attempt to unbind slot ~S in condition object ~S."
394 (defmethod slot-value-using-class
395 ((class structure-class
)
396 (object structure-object
)
397 (slotd structure-effective-slot-definition
))
398 (let* ((function (slot-definition-internal-reader-function slotd
))
399 (value (funcall function object
)))
400 (declare (type function function
))
401 ;; FIXME: Is this really necessary? Structure slots should surely
403 (if (eq value
+slot-unbound
+)
404 (values (slot-unbound class object
(slot-definition-name slotd
)))
407 (defmethod (setf slot-value-using-class
)
408 (new-value (class structure-class
)
409 (object structure-object
)
410 (slotd structure-effective-slot-definition
))
411 (let ((function (slot-definition-internal-writer-function slotd
)))
412 (declare (type function function
))
413 (funcall function new-value object
)))
415 (defmethod slot-boundp-using-class
416 ((class structure-class
)
417 (object structure-object
)
418 (slotd structure-effective-slot-definition
))
421 (defmethod slot-makunbound-using-class
422 ((class structure-class
)
423 (object structure-object
)
424 (slotd structure-effective-slot-definition
))
425 (error "Structure slots can't be unbound."))
427 (defmethod slot-missing
428 ((class t
) instance slot-name operation
&optional new-value
)
429 (error "~@<When attempting to ~A, the slot ~S is missing from the ~
432 (slot-value "read the slot's value (slot-value)")
434 "set the slot's value to ~S (SETF of SLOT-VALUE)"
436 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
437 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
441 (defmethod slot-unbound ((class t
) instance slot-name
)
443 (error 'unbound-slot
:name slot-name
:instance instance
)
445 :report
"Return a value as the slot-value."
446 :interactive read-evaluated-form
449 :report
"Store and return a value as the slot-value."
450 :interactive read-evaluated-form
451 (setf (slot-value instance slot-name
) v
))))
453 (defun slot-unbound-internal (instance position
)
460 ;; In the vast majority of cases location corresponds to the position
461 ;; in list. The only exceptions are when there are non-local slots
462 ;; before the one we want.
463 (slot-definition-name
464 (find position
(layout-slot-list (layout-of instance
))
465 :key
#'slot-definition-location
)))
469 ;;; FIXME: AMOP says that allocate-instance implies finalize-inheritance
470 ;;; if the class is not yet finalized, but we don't seem to be taking
471 ;;; care of this for non-standard-classes.
472 (defmethod allocate-instance ((class standard-class
) &rest initargs
)
473 (declare (ignore initargs
)
474 (inline ensure-class-finalized
))
475 (allocate-standard-instance
476 (class-wrapper (ensure-class-finalized class
))))
478 (defmethod allocate-instance ((class structure-class
) &rest initargs
)
479 (declare (ignore initargs
))
480 (let ((constructor (class-defstruct-constructor class
)))
482 (funcall constructor
)
483 (error "Don't know how to allocate ~S" class
))))
485 (defmethod allocate-instance ((class condition-class
) &rest initargs
)
486 (declare (ignore initargs
))
487 (values (allocate-condition (class-name class
))))
489 (defmethod allocate-instance ((class system-class
) &rest initargs
)
490 (declare (ignore initargs
))
491 (error "Cannot allocate an instance of ~S." class
))
493 ;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes.
494 (defmethod class-slots :before
((class slot-class
))
495 (unless (class-finalized-p class
)
496 (error 'simple-reference-error
497 :format-control
"~S called on ~S, which is not yet finalized."
498 :format-arguments
(list 'class-slots class
)
499 :references
(list '(:amop
:generic-function class-slots
)))))
501 (defun %set-slots
(object names
&rest values
)
502 (mapc (lambda (name value
)
503 (if (eq value
+slot-unbound
+)
504 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
505 (slot-makunbound object name
)
506 (setf (slot-value object name
) value
)))