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 four 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 set-wrapper (inst new
)
52 (cond ((std-instance-p inst
)
53 (setf (std-instance-wrapper inst
) new
))
54 ((fsc-instance-p inst
)
55 (setf (fsc-instance-wrapper inst
) new
))
57 (error "unrecognized instance type"))))
59 (defun swap-wrappers-and-slots (i1 i2
)
60 (with-pcl-lock ;FIXME is this sufficient?
61 (cond ((std-instance-p i1
)
62 (let ((w1 (std-instance-wrapper i1
))
63 (s1 (std-instance-slots i1
)))
64 (setf (std-instance-wrapper i1
) (std-instance-wrapper i2
))
65 (setf (std-instance-slots i1
) (std-instance-slots i2
))
66 (setf (std-instance-wrapper i2
) w1
)
67 (setf (std-instance-slots i2
) s1
)))
69 (let ((w1 (fsc-instance-wrapper i1
))
70 (s1 (fsc-instance-slots i1
)))
71 (setf (fsc-instance-wrapper i1
) (fsc-instance-wrapper i2
))
72 (setf (fsc-instance-slots i1
) (fsc-instance-slots i2
))
73 (setf (fsc-instance-wrapper i2
) w1
)
74 (setf (fsc-instance-slots i2
) s1
)))
76 (error "unrecognized instance type")))))
78 (defun find-slot-definition (class slot-name
)
79 (dolist (slot (class-slots class
) nil
)
80 (when (eql slot-name
(slot-definition-name slot
))
83 (declaim (ftype (sfunction (t symbol
) t
) slot-value
))
84 (defun slot-value (object slot-name
)
85 (let* ((class (class-of object
))
86 (slot-definition (find-slot-definition class slot-name
)))
87 (if (null slot-definition
)
88 (values (slot-missing class object slot-name
'slot-value
))
89 (slot-value-using-class class object slot-definition
))))
91 (define-compiler-macro slot-value
(&whole form object slot-name
)
92 (if (and (constantp slot-name
)
93 (interned-symbol-p (eval slot-name
)))
94 `(accessor-slot-value ,object
,slot-name
)
97 (defun set-slot-value (object slot-name new-value
)
98 (let* ((class (class-of object
))
99 (slot-definition (find-slot-definition class slot-name
)))
100 (if (null slot-definition
)
101 (progn (slot-missing class object slot-name
'setf new-value
)
103 (setf (slot-value-using-class class object slot-definition
)
106 (define-compiler-macro set-slot-value
(&whole form object slot-name new-value
)
107 (if (and (constantp slot-name
)
108 (interned-symbol-p (eval slot-name
)))
109 `(accessor-set-slot-value ,object
,slot-name
,new-value
)
112 (defun slot-boundp (object slot-name
)
113 (let* ((class (class-of object
))
114 (slot-definition (find-slot-definition class slot-name
)))
115 (if (null slot-definition
)
116 (not (not (slot-missing class object slot-name
'slot-boundp
)))
117 (slot-boundp-using-class class object slot-definition
))))
119 (setf (gdefinition 'slot-boundp-normal
) #'slot-boundp
)
121 (define-compiler-macro slot-boundp
(&whole form object slot-name
)
122 (if (and (constantp slot-name
)
123 (interned-symbol-p (eval slot-name
)))
124 `(accessor-slot-boundp ,object
,slot-name
)
127 (defun slot-makunbound (object slot-name
)
128 (let* ((class (class-of object
))
129 (slot-definition (find-slot-definition class slot-name
)))
130 (if (null slot-definition
)
131 (slot-missing class object slot-name
'slot-makunbound
)
132 (slot-makunbound-using-class class object slot-definition
))
135 (defun slot-exists-p (object slot-name
)
136 (let ((class (class-of object
)))
137 (not (null (find-slot-definition class slot-name
)))))
139 ;;; This isn't documented, but is used within PCL in a number of print
140 ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
141 (defun slot-value-or-default (object slot-name
&optional
(default "unbound"))
142 (if (slot-boundp object slot-name
)
143 (slot-value object slot-name
)
146 (defun standard-instance-access (instance location
)
147 (clos-slots-ref (std-instance-slots instance
) location
))
149 (defun funcallable-standard-instance-access (instance location
)
150 (clos-slots-ref (fsc-instance-slots instance
) location
))
152 (defmethod slot-value-using-class ((class std-class
)
154 (slotd standard-effective-slot-definition
))
155 (check-obsolete-instance object
)
156 (let* ((location (slot-definition-location slotd
))
157 (value (typecase location
159 (cond ((std-instance-p object
)
160 (clos-slots-ref (std-instance-slots object
)
162 ((fsc-instance-p object
)
163 (clos-slots-ref (fsc-instance-slots object
)
165 (t (error "unrecognized instance type"))))
169 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
170 allocation, so it can't be read by the default ~
172 slotd
'slot-value-using-class
)))))
173 (if (eq value
+slot-unbound
+)
174 (values (slot-unbound class object
(slot-definition-name slotd
)))
177 (defmethod (setf slot-value-using-class
)
178 (new-value (class std-class
)
180 (slotd standard-effective-slot-definition
))
181 (check-obsolete-instance object
)
182 (let ((location (slot-definition-location slotd
)))
185 (cond ((std-instance-p object
)
186 (setf (clos-slots-ref (std-instance-slots object
) location
)
188 ((fsc-instance-p object
)
189 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
191 (t (error "unrecognized instance type"))))
193 (setf (cdr location
) new-value
))
195 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
196 so it can't be written by the default ~S method.~:@>"
197 slotd
'(setf slot-value-using-class
))))))
199 (defmethod slot-boundp-using-class
202 (slotd standard-effective-slot-definition
))
203 (check-obsolete-instance object
)
204 (let* ((location (slot-definition-location slotd
))
205 (value (typecase location
207 (cond ((std-instance-p object
)
208 (clos-slots-ref (std-instance-slots object
)
210 ((fsc-instance-p object
)
211 (clos-slots-ref (fsc-instance-slots object
)
213 (t (error "unrecognized instance type"))))
217 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
218 allocation, so it can't be read by the default ~S ~
220 slotd
'slot-boundp-using-class
)))))
221 (not (eq value
+slot-unbound
+))))
223 (defmethod slot-makunbound-using-class
226 (slotd standard-effective-slot-definition
))
227 (check-obsolete-instance object
)
228 (let ((location (slot-definition-location slotd
)))
231 (cond ((std-instance-p object
)
232 (setf (clos-slots-ref (std-instance-slots object
) location
)
234 ((fsc-instance-p object
)
235 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
237 (t (error "unrecognized instance type"))))
239 (setf (cdr location
) +slot-unbound
+))
241 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
242 so it can't be written by the default ~S method.~@:>"
243 slotd
'slot-makunbound-using-class
))))
246 (defmethod slot-value-using-class
247 ((class condition-class
)
249 (slotd condition-effective-slot-definition
))
250 (let ((fun (slot-definition-reader-function slotd
)))
251 (declare (type function fun
))
252 (funcall fun object
)))
254 (defmethod (setf slot-value-using-class
)
256 (class condition-class
)
258 (slotd condition-effective-slot-definition
))
259 (let ((fun (slot-definition-writer-function slotd
)))
260 (declare (type function fun
))
261 (funcall fun new-value object
)))
263 (defmethod slot-boundp-using-class
264 ((class condition-class
)
266 (slotd condition-effective-slot-definition
))
267 (let ((fun (slot-definition-boundp-function slotd
)))
268 (declare (type function fun
))
269 (funcall fun object
)))
271 (defmethod slot-makunbound-using-class ((class condition-class
) object slot
)
272 (error "attempt to unbind slot ~S in condition object ~S."
275 (defmethod slot-value-using-class
276 ((class structure-class
)
277 (object structure-object
)
278 (slotd structure-effective-slot-definition
))
279 (let* ((function (slot-definition-internal-reader-function slotd
))
280 (value (funcall function object
)))
281 (declare (type function function
))
282 (if (eq value
+slot-unbound
+)
283 (values (slot-unbound class object
(slot-definition-name slotd
)))
286 (defmethod (setf slot-value-using-class
)
287 (new-value (class structure-class
)
288 (object structure-object
)
289 (slotd structure-effective-slot-definition
))
290 (let ((function (slot-definition-internal-writer-function slotd
)))
291 (declare (type function function
))
292 (funcall function new-value object
)))
294 (defmethod slot-boundp-using-class
295 ((class structure-class
)
296 (object structure-object
)
297 (slotd structure-effective-slot-definition
))
300 (defmethod slot-makunbound-using-class
301 ((class structure-class
)
302 (object structure-object
)
303 (slotd structure-effective-slot-definition
))
304 (error "Structure slots can't be unbound."))
306 (defmethod slot-missing
307 ((class t
) instance slot-name operation
&optional new-value
)
308 (error "~@<When attempting to ~A, the slot ~S is missing from the ~
311 (slot-value "read the slot's value (slot-value)")
313 "set the slot's value to ~S (SETF of SLOT-VALUE)"
315 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
316 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
320 (defmethod slot-unbound ((class t
) instance slot-name
)
321 (error 'unbound-slot
:name slot-name
:instance instance
))
323 (defun slot-unbound-internal (instance position
)
330 (nth position
(wrapper-instance-slots-layout (wrapper-of instance
))))
334 (defmethod allocate-instance ((class standard-class
) &rest initargs
)
335 (declare (ignore initargs
))
336 (unless (class-finalized-p class
) (finalize-inheritance class
))
337 (allocate-standard-instance (class-wrapper class
)))
339 (defmethod allocate-instance ((class structure-class
) &rest initargs
)
340 (declare (ignore initargs
))
341 (let ((constructor (class-defstruct-constructor class
)))
343 (funcall constructor
)
344 (error "can't allocate an instance of class ~S" (class-name class
)))))
346 (defmethod allocate-instance ((class condition-class
) &rest initargs
)
347 (declare (ignore initargs
))
348 (make-condition (class-name class
)))