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 (unbound-marker-p 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 (unbound-marker-p old
) (neq old old-value
))
204 (slot-unbound (wrapper-class* wrapper
) object slot-name
)
207 (defun slot-boundp (object slot-name
)
208 (let* ((wrapper (valid-wrapper-of object
))
209 (cell (find-slot-cell wrapper slot-name
))
210 (location (car cell
))
212 (cond ((fixnump location
)
213 (if (std-instance-p object
)
214 (standard-instance-access object location
)
215 (funcallable-standard-instance-access object location
)))
217 (return-from slot-boundp
219 (funcall (slot-info-boundp (cdr cell
)) object
)
220 (and (slot-missing (wrapper-class* wrapper
) object
221 slot-name
'slot-boundp
)
223 ((listp location
) ; forcibly transform CONSP to LISTP
226 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell
)))))
227 (not (unbound-marker-p value
))))
229 (defun slot-makunbound (object slot-name
)
230 (let* ((wrapper (valid-wrapper-of object
))
231 (cell (find-slot-cell wrapper slot-name
))
232 (location (car cell
)))
233 (cond ((fixnump location
)
234 (if (std-instance-p object
)
235 (setf (standard-instance-access object location
) +slot-unbound
+)
236 (setf (funcallable-standard-instance-access object location
)
240 (let ((class (wrapper-class* wrapper
)))
241 (slot-makunbound-using-class class object
242 (find-slot-definition class slot-name
)))
243 (slot-missing (wrapper-class* wrapper
) object slot-name
245 ((listp location
) ; forcibly transform CONSP to LISTP
246 (setf (cdr location
) +slot-unbound
+))
248 (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell
))))
251 ;; Note that CLHS "encourages" implementors to base this on
252 ;; SLOT-EXISTS-P-USING-CLASS, whereas 88-002R made no such claim,
253 ;; however Appendix D of AMOP sketches out such an implementation.
254 (defun slot-exists-p (object slot-name
)
255 (not (null (find-slot-cell (valid-wrapper-of object
) slot-name
))))
257 (defun slot-value-for-printing (object slot-name
)
258 (if (slot-boundp object slot-name
)
259 (slot-value object slot-name
)
260 (load-time-value (make-unprintable-object "unbound slot") t
)))
262 (defmethod slot-value-using-class ((class std-class
)
263 (object standard-object
)
264 (slotd standard-effective-slot-definition
))
265 ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
266 ;; instances. Are users allowed to call this directly?
267 (check-obsolete-instance object
)
268 (let* ((location (slot-definition-location slotd
))
272 (cond ((std-instance-p object
)
273 (clos-slots-ref (std-instance-slots object
)
275 ((fsc-instance-p object
)
276 (clos-slots-ref (fsc-instance-slots object
)
278 (t (bug "unrecognized instance type in ~S"
279 'slot-value-using-class
))))
283 (instance-structure-protocol-error slotd
284 'slot-value-using-class
)))))
285 (if (unbound-marker-p value
)
286 (values (slot-unbound class object
(slot-definition-name slotd
)))
289 (defmethod (setf slot-value-using-class
)
290 (new-value (class std-class
)
291 (object standard-object
)
292 (slotd standard-effective-slot-definition
))
293 ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
294 ;; instances. Are users allowed to call this directly?
295 (check-obsolete-instance object
)
296 (let* ((info (slot-definition-info slotd
))
297 (location (slot-definition-location slotd
))
298 (typecheck (slot-info-typecheck info
))
299 (new-value (if typecheck
300 (funcall (the function typecheck
) new-value
)
304 (cond ((std-instance-p object
)
305 (setf (clos-slots-ref (std-instance-slots object
) location
)
307 ((fsc-instance-p object
)
308 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
310 (t (bug "unrecognized instance type in ~S"
311 '(setf slot-value-using-class
)))))
313 (setf (cdr location
) new-value
))
315 (instance-structure-protocol-error
316 slotd
'(setf slot-value-using-class
))))))
318 (defmethod slot-boundp-using-class
320 (object standard-object
)
321 (slotd standard-effective-slot-definition
))
322 ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
323 ;; instances. Are users allowed to call this directly?
324 (check-obsolete-instance object
)
325 (let* ((location (slot-definition-location slotd
))
329 (cond ((std-instance-p object
)
330 (clos-slots-ref (std-instance-slots object
)
332 ((fsc-instance-p object
)
333 (clos-slots-ref (fsc-instance-slots object
)
335 (t (bug "unrecognized instance type in ~S"
336 'slot-boundp-using-class
))))
340 (instance-structure-protocol-error slotd
341 'slot-boundp-using-class
)))))
342 (not (unbound-marker-p value
))))
344 (defmethod slot-makunbound-using-class
346 (object standard-object
)
347 (slotd standard-effective-slot-definition
))
348 (check-obsolete-instance object
)
349 (let ((location (slot-definition-location slotd
)))
352 (cond ((std-instance-p object
)
353 (setf (clos-slots-ref (std-instance-slots object
) location
)
355 ((fsc-instance-p object
)
356 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
358 (t (bug "unrecognized instance type in ~S"
359 'slot-makunbound-using-class
))))
361 (setf (cdr location
) +slot-unbound
+))
363 (instance-structure-protocol-error slotd
364 'slot-makunbound-using-class
))))
367 (defmethod slot-value-using-class
368 ((class condition-class
)
370 (slotd condition-effective-slot-definition
))
371 (let ((fun (slot-info-reader (slot-definition-info slotd
))))
372 (funcall fun object
)))
374 (defmethod (setf slot-value-using-class
)
376 (class condition-class
)
378 (slotd condition-effective-slot-definition
))
379 (let ((fun (slot-info-writer (slot-definition-info slotd
))))
380 (funcall fun new-value object
)))
382 (defmethod slot-boundp-using-class
383 ((class condition-class
)
385 (slotd condition-effective-slot-definition
))
386 (let ((fun (slot-info-boundp (slot-definition-info slotd
))))
387 (funcall fun object
)))
389 (defmethod slot-makunbound-using-class ((class condition-class
) object slot
)
390 (error "attempt to unbind slot ~S in condition object ~S."
393 (defmethod slot-value-using-class
394 ((class structure-class
)
395 (object structure-object
)
396 (slotd structure-effective-slot-definition
))
397 (let* ((function (slot-definition-internal-reader-function slotd
))
398 (value (funcall function object
)))
399 (declare (type function function
))
400 ;; FIXME: Is this really necessary? Structure slots should surely
402 (if (unbound-marker-p value
)
403 (values (slot-unbound class object
(slot-definition-name slotd
)))
406 (defmethod (setf slot-value-using-class
)
407 (new-value (class structure-class
)
408 (object structure-object
)
409 (slotd structure-effective-slot-definition
))
410 (let ((function (slot-definition-internal-writer-function slotd
)))
411 (declare (type function function
))
412 (funcall function new-value object
)))
414 (defmethod slot-boundp-using-class
415 ((class structure-class
)
416 (object structure-object
)
417 (slotd structure-effective-slot-definition
))
420 (defmethod slot-makunbound-using-class
421 ((class structure-class
)
422 (object structure-object
)
423 (slotd structure-effective-slot-definition
))
424 (error "Structure slots can't be unbound."))
426 (defmethod slot-missing
427 ((class t
) instance slot-name operation
&optional new-value
)
428 (error "~@<When attempting to ~A, the slot ~S is missing from the ~
431 (slot-value "read the slot's value (slot-value)")
433 "set the slot's value to ~S (SETF of SLOT-VALUE)"
435 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
436 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
440 (defmethod slot-unbound ((class t
) instance slot-name
)
442 (error 'unbound-slot
:name slot-name
:instance instance
)
444 :report
"Return a value as the slot-value."
445 :interactive read-evaluated-form
448 :report
"Store and return a value as the slot-value."
449 :interactive read-evaluated-form
450 (setf (slot-value instance slot-name
) v
))))
452 (defun slot-unbound-internal (instance position
)
459 ;; In the vast majority of cases location corresponds to the position
460 ;; in list. The only exceptions are when there are non-local slots
461 ;; before the one we want.
462 (slot-definition-name
463 (find position
(layout-slot-list (layout-of instance
))
464 :key
#'slot-definition-location
)))
468 ;;; FIXME: AMOP says that allocate-instance implies finalize-inheritance
469 ;;; if the class is not yet finalized, but we don't seem to be taking
470 ;;; care of this for non-standard-classes.
471 (defmethod allocate-instance ((class standard-class
) &rest initargs
)
472 (declare (ignore initargs
)
473 (inline ensure-class-finalized
))
474 (allocate-standard-instance
475 (class-wrapper (ensure-class-finalized class
))))
477 (defmethod allocate-instance ((class structure-class
) &rest initargs
)
478 (declare (ignore initargs
))
479 (let ((constructor (class-defstruct-constructor class
)))
481 (funcall constructor
)
482 (error "Don't know how to allocate ~S" class
))))
484 (defmethod allocate-instance ((class condition-class
) &rest initargs
)
485 (declare (ignore initargs
))
486 (values (allocate-condition (class-name class
))))
488 (defmethod allocate-instance ((class system-class
) &rest initargs
)
489 (declare (ignore initargs
))
490 (error "Cannot allocate an instance of ~S." class
))
492 ;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes.
493 (defmethod class-slots :before
((class slot-class
))
494 (unless (class-finalized-p class
)
495 (error 'simple-reference-error
496 :format-control
"~S called on ~S, which is not yet finalized."
497 :format-arguments
(list 'class-slots class
)
498 :references
(list '(:amop
:generic-function class-slots
)))))
500 (defun %set-slots
(object names
&rest values
)
501 (mapc (lambda (name value
)
502 (if (unbound-marker-p value
)
503 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard.
504 (slot-makunbound object name
)
505 (setf (slot-value object name
) value
)))