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))))