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 (defun ensure-accessor (type fun-name slot-name
)
27 (labels ((slot-missing-fun (slot-name type
)
28 (let* ((method-type (ecase type
29 (slot-value 'reader-method
)
31 (slot-boundp 'boundp-method
)))
39 (slot-missing (class-of obj
) obj slot-name
45 (slot-missing (class-of obj
) obj slot-name
50 (slot-missing (class-of obj
) obj slot-name
53 (setf (getf (getf initargs
:plist
) :slot-name-lists
)
54 (list (list nil slot-name
)))
55 (setf (getf (getf initargs
:plist
) :pv-table-symbol
)
57 (list* :method-spec
(list method-type
'slot-object slot-name
)
59 (add-slot-missing-method (gf slot-name type
)
60 (multiple-value-bind (class lambda-list specializers
)
63 (values 'standard-reader-method
65 (list *the-class-slot-object
*)))
67 (values 'standard-boundp-method
69 (list *the-class-slot-object
*)))
71 (values 'standard-writer-method
73 (list *the-class-t
* *the-class-slot-object
*))))
74 (add-method gf
(make-a-method class
78 (slot-missing-fun slot-name type
)
79 "generated slot-missing method"
81 (unless (fboundp fun-name
)
82 (let ((gf (ensure-generic-function
84 :lambda-list
(ecase type
85 ((reader boundp
) '(object))
86 (writer '(new-value object
))))))
88 (reader (add-slot-missing-method gf slot-name
'slot-value
))
89 (boundp (add-slot-missing-method gf slot-name
'slot-boundp
))
90 (writer (add-slot-missing-method gf slot-name
'setf
)))
91 (setf (plist-value gf
'slot-missing-method
) t
))
94 (defmacro accessor-slot-value
(object slot-name
)
95 (aver (constantp slot-name
))
96 (let* ((slot-name (eval slot-name
))
97 (reader-name (slot-reader-name slot-name
)))
98 `(let ((.ignore.
(load-time-value
99 (ensure-accessor 'reader
',reader-name
',slot-name
))))
100 (declare (ignore .ignore.
))
101 (truly-the (values t
&optional
)
102 (funcall #',reader-name
,object
)))))
104 (defmacro accessor-set-slot-value
(object slot-name new-value
&environment env
)
105 (aver (constantp slot-name
))
106 (setq object
(macroexpand object env
))
107 (setq slot-name
(macroexpand slot-name env
))
108 (let* ((slot-name (eval slot-name
))
109 (bindings (unless (or (constantp new-value
) (atom new-value
))
110 (let ((object-var (gensym)))
111 (prog1 `((,object-var
,object
))
112 (setq object object-var
)))))
113 (writer-name (slot-writer-name slot-name
))
117 (ensure-accessor 'writer
',writer-name
',slot-name
)))
118 (.new-value.
,new-value
))
119 (declare (ignore .ignore.
))
120 (funcall #',writer-name .new-value.
,object
)
123 `(let ,bindings
,form
)
126 (defmacro accessor-slot-boundp
(object slot-name
)
127 (aver (constantp slot-name
))
128 (let* ((slot-name (eval slot-name
))
129 (boundp-name (slot-boundp-name slot-name
)))
130 `(let ((.ignore.
(load-time-value
131 (ensure-accessor 'boundp
',boundp-name
',slot-name
))))
132 (declare (ignore .ignore.
))
133 (funcall #',boundp-name
,object
))))
135 (defun make-structure-slot-boundp-function (slotd)
136 (declare (ignore slotd
))
138 (declare (ignore object
))
141 (defun get-optimized-std-accessor-method-function (class slotd name
)
143 ((structure-class-p class
)
145 (reader (slot-definition-internal-reader-function slotd
))
146 (writer (slot-definition-internal-writer-function slotd
))
147 (boundp (make-structure-slot-boundp-function slotd
))))
148 ((condition-class-p class
)
150 (reader (slot-definition-reader-function slotd
))
151 (writer (slot-definition-writer-function slotd
))
152 (boundp (slot-definition-boundp-function slotd
))))
154 (let* ((fsc-p (cond ((standard-class-p class
) nil
)
155 ((funcallable-standard-class-p class
) t
)
157 ;; Shouldn't be using the optimized-std-accessors
159 #+nil
(format t
"* warning: ~S ~S~% ~S~%"
162 (t (error "~S is not a STANDARD-CLASS." class
))))
163 (slot-name (slot-definition-name slotd
))
164 (index (slot-definition-location slotd
))
165 (function (ecase name
166 (reader #'make-optimized-std-reader-method-function
)
167 (writer #'make-optimized-std-writer-method-function
)
168 (boundp #'make-optimized-std-boundp-method-function
)))
169 (value (funcall function fsc-p slot-name index
)))
170 (declare (type function function
))
171 (values value index
)))))
173 (defun make-optimized-std-reader-method-function (fsc-p slot-name index
)
174 (declare #.
*optimize-speed
*)
180 (check-obsolete-instance instance
)
181 (let ((value (clos-slots-ref (fsc-instance-slots instance
) index
)))
182 (if (eq value
+slot-unbound
+)
184 (slot-unbound (class-of instance
) instance slot-name
))
187 (check-obsolete-instance instance
)
188 (let ((value (clos-slots-ref (std-instance-slots instance
) index
)))
189 (if (eq value
+slot-unbound
+)
191 (slot-unbound (class-of instance
) instance slot-name
))
195 (check-obsolete-instance instance
)
196 (let ((value (cdr index
)))
197 (if (eq value
+slot-unbound
+)
198 (values (slot-unbound (class-of instance
) instance slot-name
))
200 `(reader ,slot-name
)))
202 (defun make-optimized-std-writer-method-function (fsc-p slot-name index
)
203 (declare #.
*optimize-speed
*)
207 (lambda (nv instance
)
208 (check-obsolete-instance instance
)
209 (setf (clos-slots-ref (fsc-instance-slots instance
) index
)
211 (lambda (nv instance
)
212 (check-obsolete-instance instance
)
213 (setf (clos-slots-ref (std-instance-slots instance
) index
)
215 (cons (lambda (nv instance
)
216 (check-obsolete-instance instance
)
217 (setf (cdr index
) nv
))))
218 `(writer ,slot-name
)))
220 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index
)
221 (declare #.
*optimize-speed
*)
226 (check-obsolete-instance instance
)
227 (not (eq (clos-slots-ref (fsc-instance-slots instance
)
231 (check-obsolete-instance instance
)
232 (not (eq (clos-slots-ref (std-instance-slots instance
)
235 (cons (lambda (instance)
236 (check-obsolete-instance instance
)
237 (not (eq (cdr index
) +slot-unbound
+)))))
238 `(boundp ,slot-name
)))
240 (defun make-optimized-structure-slot-value-using-class-method-function (function)
241 (declare (type function function
))
242 (lambda (class object slotd
)
243 (declare (ignore class slotd
))
244 (funcall function object
)))
246 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
247 (declare (type function function
))
248 (lambda (nv class object slotd
)
249 (declare (ignore class slotd
))
250 (funcall function nv object
)))
252 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
253 (lambda (class object slotd
)
254 (declare (ignore class object slotd
))
257 (defun get-optimized-std-slot-value-using-class-method-function
260 ((structure-class-p class
)
262 (reader (make-optimized-structure-slot-value-using-class-method-function
263 (slot-definition-internal-reader-function slotd
)))
264 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
265 (slot-definition-internal-writer-function slotd
)))
266 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
267 ((condition-class-p class
)
270 (let ((fun (slot-definition-reader-function slotd
)))
271 (declare (type function fun
))
272 (lambda (class object slotd
)
273 (declare (ignore class slotd
))
274 (funcall fun object
))))
276 (let ((fun (slot-definition-writer-function slotd
)))
277 (declare (type function fun
))
278 (lambda (new-value class object slotd
)
279 (declare (ignore class slotd
))
280 (funcall fun new-value object
))))
282 (let ((fun (slot-definition-boundp-function slotd
)))
283 (declare (type function fun
))
284 (lambda (class object slotd
)
285 (declare (ignore class slotd
))
286 (funcall fun object
))))))
288 (let* ((fsc-p (cond ((standard-class-p class
) nil
)
289 ((funcallable-standard-class-p class
) t
)
290 (t (error "~S is not a standard-class" class
))))
291 (slot-name (slot-definition-name slotd
))
292 (index (slot-definition-location slotd
))
296 #'make-optimized-std-slot-value-using-class-method-function
)
298 #'make-optimized-std-setf-slot-value-using-class-method-function
)
300 #'make-optimized-std-slot-boundp-using-class-method-function
))))
301 (declare (type function function
))
302 (values (funcall function fsc-p slot-name index
) index
)))))
304 (defun make-optimized-std-slot-value-using-class-method-function
305 (fsc-p slot-name index
)
306 (declare #.
*optimize-speed
*)
309 (lambda (class instance slotd
)
310 (declare (ignore slotd
))
311 (check-obsolete-instance instance
)
312 (let ((value (clos-slots-ref (fsc-instance-slots instance
)
314 (if (eq value
+slot-unbound
+)
315 (values (slot-unbound class instance slot-name
))
317 (lambda (class instance slotd
)
318 (declare (ignore slotd
))
319 (check-obsolete-instance instance
)
320 (let ((value (clos-slots-ref (std-instance-slots instance
)
322 (if (eq value
+slot-unbound
+)
323 (values (slot-unbound class instance slot-name
))
325 (cons (lambda (class instance slotd
)
326 (declare (ignore slotd
))
327 (check-obsolete-instance instance
)
328 (let ((value (cdr index
)))
329 (if (eq value
+slot-unbound
+)
330 (values (slot-unbound class instance slot-name
))
333 (defun make-optimized-std-setf-slot-value-using-class-method-function
334 (fsc-p slot-name index
)
335 (declare #.
*optimize-speed
*)
336 (declare (ignore slot-name
))
339 (lambda (nv class instance slotd
)
340 (declare (ignore class slotd
))
341 (check-obsolete-instance instance
)
342 (setf (clos-slots-ref (fsc-instance-slots instance
) index
)
344 (lambda (nv class instance slotd
)
345 (declare (ignore class slotd
))
346 (check-obsolete-instance instance
)
347 (setf (clos-slots-ref (std-instance-slots instance
) index
)
349 (cons (lambda (nv class instance slotd
)
350 (declare (ignore class slotd
))
351 (check-obsolete-instance instance
)
352 (setf (cdr index
) nv
)))))
354 (defun make-optimized-std-slot-boundp-using-class-method-function
355 (fsc-p slot-name index
)
356 (declare #.
*optimize-speed
*)
357 (declare (ignore slot-name
))
360 (lambda (class instance slotd
)
361 (declare (ignore class slotd
))
362 (check-obsolete-instance instance
)
363 (not (eq (clos-slots-ref (fsc-instance-slots instance
) index
)
365 (lambda (class instance slotd
)
366 (declare (ignore class slotd
))
367 (check-obsolete-instance instance
)
368 (not (eq (clos-slots-ref (std-instance-slots instance
) index
)
370 (cons (lambda (class instance slotd
)
371 (declare (ignore class slotd
))
372 (check-obsolete-instance instance
)
373 (not (eq (cdr index
) +slot-unbound
+))))))
375 (defun get-accessor-from-svuc-method-function (class slotd sdfun name
)
376 (macrolet ((emf-funcall (emf &rest args
)
377 `(invoke-effective-method-function ,emf nil
,@args
)))
380 (reader (lambda (instance)
381 (emf-funcall sdfun class instance slotd
)))
382 (writer (lambda (nv instance
)
383 (emf-funcall sdfun nv class instance slotd
)))
384 (boundp (lambda (instance)
385 (emf-funcall sdfun class instance slotd
))))
386 `(,name
,(class-name class
) ,(slot-definition-name slotd
)))))
388 (defun make-internal-reader-method-function (class-name slot-name
)
389 (list* :method-spec
`(internal-reader-method ,class-name
,slot-name
)
390 (make-method-function
392 (let ((wrapper (get-instance-wrapper-or-nil instance
)))
394 (let* ((class (wrapper-class* wrapper
))
395 (index (or (instance-slot-index wrapper slot-name
)
397 (wrapper-class-slots wrapper
)))))
400 (let ((value (clos-slots-ref (get-slots instance
)
402 (if (eq value
+slot-unbound
+)
403 (values (slot-unbound (class-of instance
)
408 (let ((value (cdr index
)))
409 (if (eq value
+slot-unbound
+)
410 (values (slot-unbound (class-of instance
)
415 (error "~@<The wrapper for class ~S does not have ~
418 (slot-value instance slot-name
)))))))
420 (defun make-std-reader-method-function (class-name slot-name
)
421 (let* ((pv-table-symbol (gensym))
423 (make-method-function
425 (pv-binding1 (.pv. .calls.
426 (symbol-value pv-table-symbol
)
427 (instance) (instance-slots))
428 (instance-read-internal
429 .pv. instance-slots
1
430 (slot-value instance slot-name
))))))))
431 (setf (getf (getf initargs
:plist
) :slot-name-lists
)
432 (list (list nil slot-name
)))
433 (setf (getf (getf initargs
:plist
) :pv-table-symbol
) pv-table-symbol
)
434 (list* :method-spec
`(reader-method ,class-name
,slot-name
)
437 (defun make-std-writer-method-function (class-name slot-name
)
438 (let* ((pv-table-symbol (gensym))
440 (make-method-function
441 (lambda (nv instance
)
442 (pv-binding1 (.pv. .calls.
443 (symbol-value pv-table-symbol
)
444 (instance) (instance-slots))
445 (instance-write-internal
446 .pv. instance-slots
1 nv
447 (setf (slot-value instance slot-name
) nv
))))))))
448 (setf (getf (getf initargs
:plist
) :slot-name-lists
)
449 (list nil
(list nil slot-name
)))
450 (setf (getf (getf initargs
:plist
) :pv-table-symbol
) pv-table-symbol
)
451 (list* :method-spec
`(writer-method ,class-name
,slot-name
)
454 (defun make-std-boundp-method-function (class-name slot-name
)
455 (let* ((pv-table-symbol (gensym))
457 (make-method-function
459 (pv-binding1 (.pv. .calls.
460 (symbol-value pv-table-symbol
)
461 (instance) (instance-slots))
462 (instance-boundp-internal
463 .pv. instance-slots
1
464 (slot-boundp instance slot-name
))))))))
465 (setf (getf (getf initargs
:plist
) :slot-name-lists
)
466 (list (list nil slot-name
)))
467 (setf (getf (getf initargs
:plist
) :pv-table-symbol
) pv-table-symbol
)
468 (list* :method-spec
`(boundp-method ,class-name
,slot-name
)
471 (defun initialize-internal-slot-gfs (slot-name &optional type
)
472 (macrolet ((frob (type name-fun add-fun ll
)
473 `(when (or (null type
) (eq type
',type
))
474 (let* ((name (,name-fun slot-name
))
475 (gf (ensure-generic-function name
477 (methods (generic-function-methods gf
)))
478 (when (or (null methods
)
479 (plist-value gf
'slot-missing-method
))
480 (setf (plist-value gf
'slot-missing-method
) nil
)
481 (,add-fun
*the-class-slot-object
* gf slot-name
))))))
482 (frob reader slot-reader-name add-reader-method
(object))
483 (frob writer slot-writer-name add-writer-method
(new-value object
))
484 (frob boundp slot-boundp-name add-boundp-method
(object))))