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)
31 (format stream "The slot ~S is unbound in the object ~S."
32 (cell-error-name condition)
33 (unbound-slot-instance condition)))))
35 (defmethod wrapper-fetcher ((class standard-class))
36 'std-instance-wrapper)
38 (defmethod slots-fetcher ((class standard-class))
41 (defmethod raw-instance-allocator ((class standard-class))
42 'allocate-standard-instance)
44 ;;; These three functions work on std-instances and fsc-instances. These are
45 ;;; instances for which it is possible to change the wrapper and the slots.
47 ;;; For these kinds of instances, most specified methods from the instance
48 ;;; structure protocol are promoted to the implementation-specific class
49 ;;; std-class. Many of these methods call these four functions.
51 (defun %swap-wrappers-and-slots (i1 i2)
52 (cond ((std-instance-p i1)
53 (let ((w1 (std-instance-wrapper i1))
54 (s1 (std-instance-slots i1)))
55 (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
56 (setf (std-instance-slots i1) (std-instance-slots i2))
57 (setf (std-instance-wrapper i2) w1)
58 (setf (std-instance-slots i2) s1)))
60 (let ((w1 (fsc-instance-wrapper i1))
61 (s1 (fsc-instance-slots i1)))
62 (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
63 (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
64 (setf (fsc-instance-wrapper i2) w1)
65 (setf (fsc-instance-slots i2) s1)))
67 (error "unrecognized instance type"))))
69 ;;;; STANDARD-INSTANCE-ACCESS
71 (declaim (inline standard-instance-access (setf standard-instance-access)
72 funcallable-standard-instance-access
73 (setf funcallable-standard-instance-access)))
75 (defun standard-instance-access (instance location)
76 (clos-slots-ref (std-instance-slots instance) location))
78 (defun (setf standard-instance-access) (new-value instance location)
79 (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
81 (defun funcallable-standard-instance-access (instance location)
82 (clos-slots-ref (fsc-instance-slots instance) location))
84 (defun (setf funcallable-standard-instance-access) (new-value instance location)
85 (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
87 ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
89 (declaim (ftype (sfunction (t symbol) t) slot-value))
90 (defun slot-value (object slot-name)
91 (let* ((wrapper (valid-wrapper-of object))
92 (cell (or (find-slot-cell wrapper slot-name)
93 (return-from slot-value
94 (values (slot-missing (wrapper-class* wrapper) object slot-name
98 (cond ((fixnump location)
99 (if (std-instance-p object)
100 (standard-instance-access object location)
101 (funcallable-standard-instance-access object location)))
105 (return-from slot-value
106 (funcall (slot-info-reader (cdr cell)) object)))
108 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
109 (if (eq +slot-unbound+ value)
110 (slot-unbound (wrapper-class* wrapper) object slot-name)
113 ;;; This is used during the PCL build, but gets replaced by a deftransform
115 (define-compiler-macro slot-value (&whole form object slot-name
117 (if (and (constantp slot-name env)
118 (interned-symbol-p (constant-form-value slot-name env)))
119 `(accessor-slot-value ,object ,slot-name)
122 (defun set-slot-value (object slot-name new-value)
123 (let* ((wrapper (valid-wrapper-of object))
124 (cell (or (find-slot-cell wrapper slot-name)
125 (return-from set-slot-value
126 (values (slot-missing (wrapper-class* wrapper) object slot-name
128 (location (car cell))
130 (typecheck (slot-info-typecheck info)))
132 (funcall typecheck new-value))
133 (cond ((fixnump location)
134 (if (std-instance-p object)
135 (setf (standard-instance-access object location) new-value)
136 (setf (funcallable-standard-instance-access object location)
139 (setf (cdr location) new-value))
141 (funcall (slot-info-writer info) new-value object))
143 (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
146 ;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
147 ;;; check types when writing to slots:
148 ;;; * Doesn't have an optimizing compiler-macro
149 ;;; * Isn't special-cased in WALK-METHOD-LAMBDA
150 (defun safe-set-slot-value (object slot-name new-value)
151 (set-slot-value object slot-name new-value))
153 ;;; This is used during the PCL build, but gets replaced by a deftransform
155 (define-compiler-macro set-slot-value (&whole form object slot-name new-value
157 (if (and (constantp slot-name env)
158 (interned-symbol-p (constant-form-value slot-name env))
159 ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
160 ;; code, since it'll use the global automatically generated
161 ;; accessor, which won't do typechecking. (SLOT-OBJECT
162 ;; won't have been compiled with SAFETY 3, so SAFE-P will
163 ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION).
164 (not (safe-code-p env)))
165 `(accessor-set-slot-value ,object ,slot-name ,new-value)
168 (defun slot-boundp (object slot-name)
169 (let* ((wrapper (valid-wrapper-of object))
170 (cell (or (find-slot-cell wrapper slot-name)
171 (return-from slot-boundp
172 (and (slot-missing (wrapper-class* wrapper) object slot-name
175 (location (car cell))
177 (cond ((fixnump location)
178 (if (std-instance-p object)
179 (standard-instance-access object location)
180 (funcallable-standard-instance-access object location)))
184 (return-from slot-boundp
185 (funcall (slot-info-boundp (cdr cell)) object)))
187 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
188 (not (eq +slot-unbound+ value))))
190 (define-compiler-macro slot-boundp (&whole form object slot-name
192 (if (and (constantp slot-name env)
193 (interned-symbol-p (constant-form-value slot-name env)))
194 `(accessor-slot-boundp ,object ,slot-name)
197 (defun slot-makunbound (object slot-name)
198 (let* ((wrapper (valid-wrapper-of object))
199 (cell (find-slot-cell wrapper slot-name))
200 (location (car cell)))
201 (cond ((fixnump location)
202 (if (std-instance-p object)
203 (setf (standard-instance-access object location) +slot-unbound+)
204 (setf (funcallable-standard-instance-access object location)
207 (setf (cdr location) +slot-unbound+))
209 (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
211 (let ((class (wrapper-class* wrapper)))
212 (slot-makunbound-using-class class object (find-slot-definition class slot-name))))
214 (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
217 (defun slot-exists-p (object slot-name)
218 (let ((class (class-of object)))
219 (not (null (find-slot-definition class slot-name)))))
221 (defvar *unbound-slot-value-marker* (make-unprintable-object "unbound slot"))
223 ;;; This isn't documented, but is used within PCL in a number of print
224 ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
225 (defun slot-value-or-default (object slot-name &optional
226 (default *unbound-slot-value-marker*))
227 (if (slot-boundp object slot-name)
228 (slot-value object slot-name)
231 (defmethod slot-value-using-class ((class std-class)
232 (object standard-object)
233 (slotd standard-effective-slot-definition))
234 ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
235 ;; instances. Are users allowed to call this directly?
236 (check-obsolete-instance object)
237 (let* ((location (slot-definition-location slotd))
241 (cond ((std-instance-p object)
242 (clos-slots-ref (std-instance-slots object)
244 ((fsc-instance-p object)
245 (clos-slots-ref (fsc-instance-slots object)
247 (t (bug "unrecognized instance type in ~S"
248 'slot-value-using-class))))
252 (instance-structure-protocol-error slotd
253 'slot-value-using-class)))))
254 (if (eq value +slot-unbound+)
255 (values (slot-unbound class object (slot-definition-name slotd)))
258 (defmethod (setf slot-value-using-class)
259 (new-value (class std-class)
260 (object standard-object)
261 (slotd standard-effective-slot-definition))
262 ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
263 ;; instances. Are users allowed to call this directly?
264 (check-obsolete-instance object)
265 (let* ((info (slot-definition-info slotd))
266 (location (slot-definition-location slotd))
267 (typecheck (slot-info-typecheck info))
268 (new-value (if typecheck
269 (funcall (the function typecheck) new-value)
273 (cond ((std-instance-p object)
274 (setf (clos-slots-ref (std-instance-slots object) location)
276 ((fsc-instance-p object)
277 (setf (clos-slots-ref (fsc-instance-slots object) location)
279 (t (bug "unrecognized instance type in ~S"
280 '(setf slot-value-using-class)))))
282 (setf (cdr location) new-value))
284 (instance-structure-protocol-error
285 slotd '(setf slot-value-using-class))))))
287 (defmethod slot-boundp-using-class
289 (object standard-object)
290 (slotd standard-effective-slot-definition))
291 ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
292 ;; instances. Are users allowed to call this directly?
293 (check-obsolete-instance object)
294 (let* ((location (slot-definition-location slotd))
298 (cond ((std-instance-p object)
299 (clos-slots-ref (std-instance-slots object)
301 ((fsc-instance-p object)
302 (clos-slots-ref (fsc-instance-slots object)
304 (t (bug "unrecognized instance type in ~S"
305 'slot-boundp-using-class))))
309 (instance-structure-protocol-error slotd
310 'slot-boundp-using-class)))))
311 (not (eq value +slot-unbound+))))
313 (defmethod slot-makunbound-using-class
315 (object standard-object)
316 (slotd standard-effective-slot-definition))
317 (check-obsolete-instance object)
318 (let ((location (slot-definition-location slotd)))
321 (cond ((std-instance-p object)
322 (setf (clos-slots-ref (std-instance-slots object) location)
324 ((fsc-instance-p object)
325 (setf (clos-slots-ref (fsc-instance-slots object) location)
327 (t (bug "unrecognized instance type in ~S"
328 'slot-makunbound-using-class))))
330 (setf (cdr location) +slot-unbound+))
332 (instance-structure-protocol-error slotd
333 'slot-makunbound-using-class))))
336 (defmethod slot-value-using-class
337 ((class condition-class)
339 (slotd condition-effective-slot-definition))
340 (let ((fun (slot-info-reader (slot-definition-info slotd))))
341 (funcall fun object)))
343 (defmethod (setf slot-value-using-class)
345 (class condition-class)
347 (slotd condition-effective-slot-definition))
348 (let ((fun (slot-info-writer (slot-definition-info slotd))))
349 (funcall fun new-value object)))
351 (defmethod slot-boundp-using-class
352 ((class condition-class)
354 (slotd condition-effective-slot-definition))
355 (let ((fun (slot-info-boundp (slot-definition-info slotd))))
356 (funcall fun object)))
358 (defmethod slot-makunbound-using-class ((class condition-class) object slot)
359 (error "attempt to unbind slot ~S in condition object ~S."
362 (defmethod slot-value-using-class
363 ((class structure-class)
364 (object structure-object)
365 (slotd structure-effective-slot-definition))
366 (let* ((function (slot-definition-internal-reader-function slotd))
367 (value (funcall function object)))
368 (declare (type function function))
369 ;; FIXME: Is this really necessary? Structure slots should surely
371 (if (eq value +slot-unbound+)
372 (values (slot-unbound class object (slot-definition-name slotd)))
375 (defmethod (setf slot-value-using-class)
376 (new-value (class structure-class)
377 (object structure-object)
378 (slotd structure-effective-slot-definition))
379 (let ((function (slot-definition-internal-writer-function slotd)))
380 (declare (type function function))
381 (funcall function new-value object)))
383 (defmethod slot-boundp-using-class
384 ((class structure-class)
385 (object structure-object)
386 (slotd structure-effective-slot-definition))
389 (defmethod slot-makunbound-using-class
390 ((class structure-class)
391 (object structure-object)
392 (slotd structure-effective-slot-definition))
393 (error "Structure slots can't be unbound."))
395 (defmethod slot-missing
396 ((class t) instance slot-name operation &optional new-value)
397 (error "~@<When attempting to ~A, the slot ~S is missing from the ~
400 (slot-value "read the slot's value (slot-value)")
402 "set the slot's value to ~S (SETF of SLOT-VALUE)"
404 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
405 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
409 (defmethod slot-unbound ((class t) instance slot-name)
411 (error 'unbound-slot :name slot-name :instance instance)
413 :report "Return a value as the slot-value."
414 :interactive read-evaluated-form
417 :report "Store and return a value as the slot-value."
418 :interactive read-evaluated-form
419 (setf (slot-value instance slot-name) v))))
421 (defun slot-unbound-internal (instance position)
428 (car (nth position (wrapper-instance-slots-layout (wrapper-of instance)))))
432 ;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance
433 ;;; if the class is not yet finalized, but we don't seem to be taking
434 ;;; care of this for non-standard-classes.x
435 (defmethod allocate-instance ((class standard-class) &rest initargs)
436 (declare (ignore initargs))
437 (unless (class-finalized-p class)
438 (finalize-inheritance class))
439 (allocate-standard-instance (class-wrapper class)))
441 (defmethod allocate-instance ((class structure-class) &rest initargs)
442 (declare (ignore initargs))
443 (let ((constructor (class-defstruct-constructor class)))
445 (funcall constructor)
446 (error "Don't know how to allocate ~S" class))))
448 ;;; FIXME: It would be nicer to have allocate-instance return
449 ;;; uninitialized objects for conditions as well.
450 (defmethod allocate-instance ((class condition-class) &rest initargs)
451 (declare (ignore initargs))
452 (make-condition (class-name class)))
454 (defmethod allocate-instance ((class built-in-class) &rest initargs)
455 (declare (ignore initargs))
456 (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
458 ;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes.
459 (defmethod class-slots :before ((class slot-class))
460 (unless (class-finalized-p class)
461 (error 'simple-reference-error
462 :format-control "~S called on ~S, which is not yet finalized."
463 :format-arguments (list 'class-slots class)
464 :references (list '(:amop :generic-function class-slots)))))