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 fun-name)))
84 (reader (add-slot-missing-method gf slot-name 'slot-value))
85 (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
86 (writer (add-slot-missing-method gf slot-name 'setf)))
87 (setf (plist-value gf 'slot-missing-method) t))
90 (defmacro accessor-slot-value (object slot-name)
91 (aver (constantp slot-name))
92 (let* ((slot-name (eval slot-name))
93 (reader-name (slot-reader-name slot-name)))
94 `(let ((.ignore. (load-time-value
95 (ensure-accessor 'reader ',reader-name ',slot-name))))
96 (declare (ignore .ignore.))
97 (truly-the (values t &optional)
98 (funcall #',reader-name ,object)))))
100 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
101 (aver (constantp slot-name))
102 (setq object (macroexpand object env))
103 (setq slot-name (macroexpand slot-name env))
104 (let* ((slot-name (eval slot-name))
105 (bindings (unless (or (constantp new-value) (atom new-value))
106 (let ((object-var (gensym)))
107 (prog1 `((,object-var ,object))
108 (setq object object-var)))))
109 (writer-name (slot-writer-name slot-name))
113 (ensure-accessor 'writer ',writer-name ',slot-name)))
114 (.new-value. ,new-value))
115 (declare (ignore .ignore.))
116 (funcall #',writer-name .new-value. ,object)
119 `(let ,bindings ,form)
122 (defmacro accessor-slot-boundp (object slot-name)
123 (aver (constantp slot-name))
124 (let* ((slot-name (eval slot-name))
125 (boundp-name (slot-boundp-name slot-name)))
126 `(let ((.ignore. (load-time-value
127 (ensure-accessor 'boundp ',boundp-name ',slot-name))))
128 (declare (ignore .ignore.))
129 (funcall #',boundp-name ,object))))
131 (defun make-structure-slot-boundp-function (slotd)
132 (declare (ignore slotd))
134 (declare (ignore object))
137 (defun get-optimized-std-accessor-method-function (class slotd name)
139 ((structure-class-p class)
141 (reader (slot-definition-internal-reader-function slotd))
142 (writer (slot-definition-internal-writer-function slotd))
143 (boundp (make-structure-slot-boundp-function slotd))))
144 ((condition-class-p class)
146 (reader (slot-definition-reader-function slotd))
147 (writer (slot-definition-writer-function slotd))
148 (boundp (slot-definition-boundp-function slotd))))
150 (let* ((fsc-p (cond ((standard-class-p class) nil)
151 ((funcallable-standard-class-p class) t)
153 ;; Shouldn't be using the optimized-std-accessors
155 #+nil (format t "* warning: ~S ~S~% ~S~%"
158 (t (error "~S is not a STANDARD-CLASS." class))))
159 (slot-name (slot-definition-name slotd))
160 (index (slot-definition-location slotd))
161 (function (ecase name
162 (reader #'make-optimized-std-reader-method-function)
163 (writer #'make-optimized-std-writer-method-function)
164 (boundp #'make-optimized-std-boundp-method-function)))
165 (value (funcall function fsc-p slot-name index)))
166 (declare (type function function))
167 (values value index)))))
169 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
170 (declare #.*optimize-speed*)
176 (check-obsolete-instance instance)
177 (let ((value (clos-slots-ref (fsc-instance-slots instance) index)))
178 (if (eq value +slot-unbound+)
180 (slot-unbound (class-of instance) instance slot-name))
183 (check-obsolete-instance instance)
184 (let ((value (clos-slots-ref (std-instance-slots instance) index)))
185 (if (eq value +slot-unbound+)
187 (slot-unbound (class-of instance) instance slot-name))
191 (check-obsolete-instance instance)
192 (let ((value (cdr index)))
193 (if (eq value +slot-unbound+)
194 (values (slot-unbound (class-of instance) instance slot-name))
196 `(reader ,slot-name)))
198 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
199 (declare #.*optimize-speed*)
203 (lambda (nv instance)
204 (check-obsolete-instance instance)
205 (setf (clos-slots-ref (fsc-instance-slots instance) index)
207 (lambda (nv instance)
208 (check-obsolete-instance instance)
209 (setf (clos-slots-ref (std-instance-slots instance) index)
211 (cons (lambda (nv instance)
212 (check-obsolete-instance instance)
213 (setf (cdr index) nv))))
214 `(writer ,slot-name)))
216 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
217 (declare #.*optimize-speed*)
222 (check-obsolete-instance instance)
223 (not (eq (clos-slots-ref (fsc-instance-slots instance)
227 (check-obsolete-instance instance)
228 (not (eq (clos-slots-ref (std-instance-slots instance)
231 (cons (lambda (instance)
232 (check-obsolete-instance instance)
233 (not (eq (cdr index) +slot-unbound+)))))
234 `(boundp ,slot-name)))
236 (defun make-optimized-structure-slot-value-using-class-method-function (function)
237 (declare (type function function))
238 (lambda (class object slotd)
239 (declare (ignore class slotd))
240 (funcall function object)))
242 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
243 (declare (type function function))
244 (lambda (nv class object slotd)
245 (declare (ignore class slotd))
246 (funcall function nv object)))
248 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
249 (lambda (class object slotd)
250 (declare (ignore class object slotd))
253 (defun get-optimized-std-slot-value-using-class-method-function
256 ((structure-class-p class)
258 (reader (make-optimized-structure-slot-value-using-class-method-function
259 (slot-definition-internal-reader-function slotd)))
260 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
261 (slot-definition-internal-writer-function slotd)))
262 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
263 ((condition-class-p class)
266 (let ((fun (slot-definition-reader-function slotd)))
267 (declare (type function fun))
268 (lambda (class object slotd)
269 (declare (ignore class slotd))
270 (funcall fun object))))
272 (let ((fun (slot-definition-writer-function slotd)))
273 (declare (type function fun))
274 (lambda (new-value class object slotd)
275 (declare (ignore class slotd))
276 (funcall fun new-value object))))
278 (let ((fun (slot-definition-boundp-function slotd)))
279 (declare (type function fun))
280 (lambda (class object slotd)
281 (declare (ignore class slotd))
282 (funcall fun object))))))
284 (let* ((fsc-p (cond ((standard-class-p class) nil)
285 ((funcallable-standard-class-p class) t)
286 (t (error "~S is not a standard-class" class))))
287 (slot-name (slot-definition-name slotd))
288 (index (slot-definition-location slotd))
292 #'make-optimized-std-slot-value-using-class-method-function)
294 #'make-optimized-std-setf-slot-value-using-class-method-function)
296 #'make-optimized-std-slot-boundp-using-class-method-function))))
297 (declare (type function function))
298 (values (funcall function fsc-p slot-name index) index)))))
300 (defun make-optimized-std-slot-value-using-class-method-function
301 (fsc-p slot-name index)
302 (declare #.*optimize-speed*)
305 (lambda (class instance slotd)
306 (declare (ignore slotd))
307 (check-obsolete-instance instance)
308 (let ((value (clos-slots-ref (fsc-instance-slots instance)
310 (if (eq value +slot-unbound+)
311 (values (slot-unbound class instance slot-name))
313 (lambda (class instance slotd)
314 (declare (ignore slotd))
315 (check-obsolete-instance instance)
316 (let ((value (clos-slots-ref (std-instance-slots instance)
318 (if (eq value +slot-unbound+)
319 (values (slot-unbound class instance slot-name))
321 (cons (lambda (class instance slotd)
322 (declare (ignore slotd))
323 (check-obsolete-instance instance)
324 (let ((value (cdr index)))
325 (if (eq value +slot-unbound+)
326 (values (slot-unbound class instance slot-name))
329 (defun make-optimized-std-setf-slot-value-using-class-method-function
330 (fsc-p slot-name index)
331 (declare #.*optimize-speed*)
332 (declare (ignore slot-name))
335 (lambda (nv class instance slotd)
336 (declare (ignore class slotd))
337 (check-obsolete-instance instance)
338 (setf (clos-slots-ref (fsc-instance-slots instance) index)
340 (lambda (nv class instance slotd)
341 (declare (ignore class slotd))
342 (check-obsolete-instance instance)
343 (setf (clos-slots-ref (std-instance-slots instance) index)
345 (cons (lambda (nv class instance slotd)
346 (declare (ignore class slotd))
347 (check-obsolete-instance instance)
348 (setf (cdr index) nv)))))
350 (defun make-optimized-std-slot-boundp-using-class-method-function
351 (fsc-p slot-name index)
352 (declare #.*optimize-speed*)
353 (declare (ignore slot-name))
356 (lambda (class instance slotd)
357 (declare (ignore class slotd))
358 (check-obsolete-instance instance)
359 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
361 (lambda (class instance slotd)
362 (declare (ignore class slotd))
363 (check-obsolete-instance instance)
364 (not (eq (clos-slots-ref (std-instance-slots instance) index)
366 (cons (lambda (class instance slotd)
367 (declare (ignore class slotd))
368 (check-obsolete-instance instance)
369 (not (eq (cdr index) +slot-unbound+))))))
371 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
372 (macrolet ((emf-funcall (emf &rest args)
373 `(invoke-effective-method-function ,emf nil ,@args)))
376 (reader (lambda (instance)
377 (emf-funcall sdfun class instance slotd)))
378 (writer (lambda (nv instance)
379 (emf-funcall sdfun nv class instance slotd)))
380 (boundp (lambda (instance)
381 (emf-funcall sdfun class instance slotd))))
382 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
384 (defun make-internal-reader-method-function (class-name slot-name)
385 (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
386 (make-method-function
388 (let ((wrapper (get-instance-wrapper-or-nil instance)))
390 (let* ((class (wrapper-class* wrapper))
391 (index (or (instance-slot-index wrapper slot-name)
393 (wrapper-class-slots wrapper)))))
396 (let ((value (clos-slots-ref (get-slots instance)
398 (if (eq value +slot-unbound+)
399 (values (slot-unbound (class-of instance)
404 (let ((value (cdr index)))
405 (if (eq value +slot-unbound+)
406 (values (slot-unbound (class-of instance)
411 (error "~@<The wrapper for class ~S does not have ~
414 (slot-value instance slot-name)))))))
416 (defun make-std-reader-method-function (class-name slot-name)
417 (let* ((pv-table-symbol (gensym))
419 (make-method-function
421 (pv-binding1 (.pv. .calls.
422 (symbol-value pv-table-symbol)
423 (instance) (instance-slots))
424 (instance-read-internal
425 .pv. instance-slots 1
426 (slot-value instance slot-name))))))))
427 (setf (getf (getf initargs :plist) :slot-name-lists)
428 (list (list nil slot-name)))
429 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
430 (list* :method-spec `(reader-method ,class-name ,slot-name)
433 (defun make-std-writer-method-function (class-name slot-name)
434 (let* ((pv-table-symbol (gensym))
436 (make-method-function
437 (lambda (nv instance)
438 (pv-binding1 (.pv. .calls.
439 (symbol-value pv-table-symbol)
440 (instance) (instance-slots))
441 (instance-write-internal
442 .pv. instance-slots 1 nv
443 (setf (slot-value instance slot-name) nv))))))))
444 (setf (getf (getf initargs :plist) :slot-name-lists)
445 (list nil (list nil slot-name)))
446 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
447 (list* :method-spec `(writer-method ,class-name ,slot-name)
450 (defun make-std-boundp-method-function (class-name slot-name)
451 (let* ((pv-table-symbol (gensym))
453 (make-method-function
455 (pv-binding1 (.pv. .calls.
456 (symbol-value pv-table-symbol)
457 (instance) (instance-slots))
458 (instance-boundp-internal
459 .pv. instance-slots 1
460 (slot-boundp instance slot-name))))))))
461 (setf (getf (getf initargs :plist) :slot-name-lists)
462 (list (list nil slot-name)))
463 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
464 (list* :method-spec `(boundp-method ,class-name ,slot-name)
467 (defun initialize-internal-slot-gfs (slot-name &optional type)
468 (macrolet ((frob (type name-fun add-fun)
469 `(when (or (null type) (eq type ',type))
470 (let* ((name (,name-fun slot-name))
471 (gf (ensure-generic-function name))
472 (methods (generic-function-methods gf)))
473 (when (or (null methods)
474 (plist-value gf 'slot-missing-method))
475 (setf (plist-value gf 'slot-missing-method) nil)
476 (,add-fun *the-class-slot-object* gf slot-name))))))
477 (frob reader slot-reader-name add-reader-method)
478 (frob writer slot-writer-name add-writer-method)
479 (frob boundp slot-boundp-name add-boundp-method)))