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 (slot :reader unbound-slot-slot
:initarg
:slot
))
31 (:report
(lambda (condition stream
)
32 (format stream
"The slot ~S is unbound in the object ~S."
33 (unbound-slot-slot condition
)
34 (unbound-slot-instance condition
)))))
36 (defmethod wrapper-fetcher ((class standard-class
))
37 'std-instance-wrapper
)
39 (defmethod slots-fetcher ((class standard-class
))
42 (defmethod raw-instance-allocator ((class standard-class
))
43 'allocate-standard-instance
)
45 ;;; These four functions work on std-instances and fsc-instances. These are
46 ;;; instances for which it is possible to change the wrapper and the slots.
48 ;;; For these kinds of instances, most specified methods from the instance
49 ;;; structure protocol are promoted to the implementation-specific class
50 ;;; std-class. Many of these methods call these four functions.
52 (defun set-wrapper (inst new
)
53 (cond ((std-instance-p inst
)
54 (setf (std-instance-wrapper inst
) new
))
55 ((fsc-instance-p inst
)
56 (setf (fsc-instance-wrapper inst
) new
))
58 (error "unrecognized instance type"))))
60 (defun swap-wrappers-and-slots (i1 i2
)
61 (with-pcl-lock ;FIXME is this sufficient?
62 (cond ((std-instance-p i1
)
63 (let ((w1 (std-instance-wrapper i1
))
64 (s1 (std-instance-slots i1
)))
65 (setf (std-instance-wrapper i1
) (std-instance-wrapper i2
))
66 (setf (std-instance-slots i1
) (std-instance-slots i2
))
67 (setf (std-instance-wrapper i2
) w1
)
68 (setf (std-instance-slots i2
) s1
)))
70 (let ((w1 (fsc-instance-wrapper i1
))
71 (s1 (fsc-instance-slots i1
)))
72 (setf (fsc-instance-wrapper i1
) (fsc-instance-wrapper i2
))
73 (setf (fsc-instance-slots i1
) (fsc-instance-slots i2
))
74 (setf (fsc-instance-wrapper i2
) w1
)
75 (setf (fsc-instance-slots i2
) s1
)))
77 (error "unrecognized instance type")))))
79 (defun get-class-slot-value-1 (object wrapper slot-name
)
80 (let ((entry (assoc slot-name
(wrapper-class-slots wrapper
))))
82 (slot-missing (wrapper-class wrapper
) object slot-name
'slot-value
)
83 (if (eq (cdr entry
) +slot-unbound
+)
84 (slot-unbound (wrapper-class wrapper
) object slot-name
)
87 (defun set-class-slot-value-1 (new-value object wrapper slot-name
)
88 (let ((entry (assoc slot-name
(wrapper-class-slots wrapper
))))
90 (slot-missing (wrapper-class wrapper
)
95 (setf (cdr entry
) new-value
))))
97 (defmethod class-slot-value ((class std-class
) slot-name
)
98 (let ((wrapper (class-wrapper class
))
99 (prototype (class-prototype class
)))
100 (get-class-slot-value-1 prototype wrapper slot-name
)))
102 (defmethod (setf class-slot-value
) (nv (class std-class
) slot-name
)
103 (let ((wrapper (class-wrapper class
))
104 (prototype (class-prototype class
)))
105 (set-class-slot-value-1 nv prototype wrapper slot-name
)))
107 (defun find-slot-definition (class slot-name
)
108 (dolist (slot (class-slots class
) nil
)
109 (when (eql slot-name
(slot-definition-name slot
))
112 (defun slot-value (object slot-name
)
113 (let* ((class (class-of object
))
114 (slot-definition (find-slot-definition class slot-name
)))
115 (if (null slot-definition
)
116 (slot-missing class object slot-name
'slot-value
)
117 (slot-value-using-class class object slot-definition
))))
119 (define-compiler-macro slot-value
(&whole form object slot-name
)
120 (if (and (constantp slot-name
)
121 (interned-symbol-p (eval slot-name
)))
122 `(accessor-slot-value ,object
,slot-name
)
125 (defun set-slot-value (object slot-name new-value
)
126 (let* ((class (class-of object
))
127 (slot-definition (find-slot-definition class slot-name
)))
128 (if (null slot-definition
)
129 (slot-missing class object slot-name
'setf new-value
)
130 (setf (slot-value-using-class class object slot-definition
)
133 (define-compiler-macro set-slot-value
(&whole form object slot-name new-value
)
134 (if (and (constantp slot-name
)
135 (interned-symbol-p (eval slot-name
)))
136 `(accessor-set-slot-value ,object
,slot-name
,new-value
)
139 (defun slot-boundp (object slot-name
)
140 (let* ((class (class-of object
))
141 (slot-definition (find-slot-definition class slot-name
)))
142 (if (null slot-definition
)
143 (slot-missing class object slot-name
'slot-boundp
)
144 (slot-boundp-using-class class object slot-definition
))))
146 (setf (gdefinition 'slot-boundp-normal
) #'slot-boundp
)
148 (define-compiler-macro slot-boundp
(&whole form object slot-name
)
149 (if (and (constantp slot-name
)
150 (interned-symbol-p (eval slot-name
)))
151 `(accessor-slot-boundp ,object
,slot-name
)
154 (defun slot-makunbound (object slot-name
)
155 (let* ((class (class-of object
))
156 (slot-definition (find-slot-definition class slot-name
)))
157 (if (null slot-definition
)
158 (slot-missing class object slot-name
'slot-makunbound
)
159 (slot-makunbound-using-class class object slot-definition
))))
161 (defun slot-exists-p (object slot-name
)
162 (let ((class (class-of object
)))
163 (not (null (find-slot-definition class slot-name
)))))
165 ;;; This isn't documented, but is used within PCL in a number of print
166 ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
167 (defun slot-value-or-default (object slot-name
&optional
(default "unbound"))
168 (if (slot-boundp object slot-name
)
169 (slot-value object slot-name
)
172 (defun standard-instance-access (instance location
)
173 (clos-slots-ref (std-instance-slots instance
) location
))
175 (defun funcallable-standard-instance-access (instance location
)
176 (clos-slots-ref (fsc-instance-slots instance
) location
))
178 (defmethod slot-value-using-class ((class std-class
)
180 (slotd standard-effective-slot-definition
))
181 (check-obsolete-instance object
)
182 (let* ((location (slot-definition-location slotd
))
183 (value (typecase location
185 (cond ((std-instance-p object
)
186 (clos-slots-ref (std-instance-slots object
)
188 ((fsc-instance-p object
)
189 (clos-slots-ref (fsc-instance-slots object
)
191 (t (error "unrecognized instance type"))))
195 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
196 allocation, so it can't be read by the default ~
198 slotd
'slot-value-using-class
)))))
199 (if (eq value
+slot-unbound
+)
200 (slot-unbound class object
(slot-definition-name slotd
))
203 (defmethod (setf slot-value-using-class
)
204 (new-value (class std-class
)
206 (slotd standard-effective-slot-definition
))
207 (check-obsolete-instance object
)
208 (let ((location (slot-definition-location slotd
)))
211 (cond ((std-instance-p object
)
212 (setf (clos-slots-ref (std-instance-slots object
) location
)
214 ((fsc-instance-p object
)
215 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
217 (t (error "unrecognized instance type"))))
219 (setf (cdr location
) new-value
))
221 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
222 so it can't be written by the default ~S method.~:@>"
223 slotd
'(setf slot-value-using-class
))))))
225 (defmethod slot-boundp-using-class
228 (slotd standard-effective-slot-definition
))
229 (check-obsolete-instance object
)
230 (let* ((location (slot-definition-location slotd
))
231 (value (typecase location
233 (cond ((std-instance-p object
)
234 (clos-slots-ref (std-instance-slots object
)
236 ((fsc-instance-p object
)
237 (clos-slots-ref (fsc-instance-slots object
)
239 (t (error "unrecognized instance type"))))
243 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS ~
244 allocation, so it can't be read by the default ~S ~
246 slotd
'slot-boundp-using-class
)))))
247 (not (eq value
+slot-unbound
+))))
249 (defmethod slot-makunbound-using-class
252 (slotd standard-effective-slot-definition
))
253 (check-obsolete-instance object
)
254 (let ((location (slot-definition-location slotd
)))
257 (cond ((std-instance-p object
)
258 (setf (clos-slots-ref (std-instance-slots object
) location
)
260 ((fsc-instance-p object
)
261 (setf (clos-slots-ref (fsc-instance-slots object
) location
)
263 (t (error "unrecognized instance type"))))
265 (setf (cdr location
) +slot-unbound
+))
267 (error "~@<The slot ~S has neither :INSTANCE nor :CLASS allocation, ~
268 so it can't be written by the default ~S method.~@:>"
269 slotd
'slot-makunbound-using-class
))))
272 (defmethod slot-value-using-class
273 ((class condition-class
)
275 (slotd condition-effective-slot-definition
))
276 (let ((fun (slot-definition-reader-function slotd
)))
277 (declare (type function fun
))
278 (funcall fun object
)))
280 (defmethod (setf slot-value-using-class
)
282 (class condition-class
)
284 (slotd condition-effective-slot-definition
))
285 (let ((fun (slot-definition-writer-function slotd
)))
286 (declare (type function fun
))
287 (funcall fun new-value object
)))
289 (defmethod slot-boundp-using-class
290 ((class condition-class
)
292 (slotd condition-effective-slot-definition
))
293 (let ((fun (slot-definition-boundp-function slotd
)))
294 (declare (type function fun
))
295 (funcall fun object
)))
297 (defmethod slot-makunbound-using-class ((class condition-class
) object slot
)
298 (error "attempt to unbind slot ~S in condition object ~S."
301 (defmethod slot-value-using-class
302 ((class structure-class
)
303 (object structure-object
)
304 (slotd structure-effective-slot-definition
))
305 (let* ((function (slot-definition-internal-reader-function slotd
))
306 (value (funcall function object
)))
307 (declare (type function function
))
308 (if (eq value
+slot-unbound
+)
309 (slot-unbound class object
(slot-definition-name slotd
))
312 (defmethod (setf slot-value-using-class
)
313 (new-value (class structure-class
)
314 (object structure-object
)
315 (slotd structure-effective-slot-definition
))
316 (let ((function (slot-definition-internal-writer-function slotd
)))
317 (declare (type function function
))
318 (funcall function new-value object
)))
320 (defmethod slot-boundp-using-class
321 ((class structure-class
)
322 (object structure-object
)
323 (slotd structure-effective-slot-definition
))
326 (defmethod slot-makunbound-using-class
327 ((class structure-class
)
328 (object structure-object
)
329 (slotd structure-effective-slot-definition
))
330 (error "Structure slots can't be unbound."))
332 (defmethod slot-missing
333 ((class t
) instance slot-name operation
&optional new-value
)
334 (error "~@<When attempting to ~A, the slot ~S is missing from the ~
337 (slot-value "read the slot's value (slot-value)")
339 "set the slot's value to ~S (SETF of SLOT-VALUE)"
341 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
342 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
346 (defmethod slot-unbound ((class t
) instance slot-name
)
347 (error 'unbound-slot
:slot slot-name
:instance instance
))
349 (defun slot-unbound-internal (instance position
)
350 (slot-unbound (class-of instance
) instance
354 (wrapper-instance-slots-layout (wrapper-of instance
))))
358 (defmethod allocate-instance ((class standard-class
) &rest initargs
)
359 (declare (ignore initargs
))
360 (unless (class-finalized-p class
) (finalize-inheritance class
))
361 (allocate-standard-instance (class-wrapper class
)))
363 (defmethod allocate-instance ((class structure-class
) &rest initargs
)
364 (declare (ignore initargs
))
365 (let ((constructor (class-defstruct-constructor class
)))
367 (funcall constructor
)
368 (error "can't allocate an instance of class ~S" (class-name class
)))))
370 (defmethod allocate-instance ((class condition-class
) &rest initargs
)
371 (declare (ignore initargs
))
372 (make-condition (class-name class
)))