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)))
38 (slot-missing (class-of obj) obj slot-name
43 (slot-missing (class-of obj) obj slot-name
48 (declare (ignore val))
49 (slot-missing (class-of obj) obj slot-name
51 (setf (getf (getf initargs :plist) :slot-name-lists)
52 (list (list nil slot-name)))
53 (setf (getf (getf initargs :plist) :pv-table-symbol)
55 (list* :method-spec (list method-type 'slot-object slot-name)
57 (add-slot-missing-method (gf slot-name type)
58 (multiple-value-bind (class lambda-list specializers)
61 (values 'standard-reader-method
63 (list *the-class-slot-object*)))
65 (values 'standard-boundp-method
67 (list *the-class-slot-object*)))
69 (values 'standard-writer-method
71 (list *the-class-t* *the-class-slot-object*))))
72 (add-method gf (make-a-method class
76 (slot-missing-fun slot-name type)
77 "generated slot-missing method"
79 (unless (fboundp fun-name)
80 (let ((gf (ensure-generic-function fun-name)))
82 (reader (add-slot-missing-method gf slot-name 'slot-value))
83 (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
84 (writer (add-slot-missing-method gf slot-name 'setf)))
85 (setf (plist-value gf 'slot-missing-method) t))
88 (defmacro accessor-slot-value (object slot-name)
89 (aver (constantp slot-name))
90 (let* ((slot-name (eval slot-name))
91 (reader-name (slot-reader-name slot-name)))
92 `(let ((.ignore. (load-time-value
93 (ensure-accessor 'reader ',reader-name ',slot-name))))
94 (declare (ignore .ignore.))
95 (funcall #',reader-name ,object))))
97 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
98 (aver (constantp slot-name))
99 (setq object (macroexpand object env))
100 (setq slot-name (macroexpand slot-name env))
101 (let* ((slot-name (eval slot-name))
102 (bindings (unless (or (constantp new-value) (atom new-value))
103 (let ((object-var (gensym)))
104 (prog1 `((,object-var ,object))
105 (setq object object-var)))))
106 (writer-name (slot-writer-name slot-name))
110 (ensure-accessor 'writer ',writer-name ',slot-name))))
111 (declare (ignore .ignore.))
112 (funcall #',writer-name ,new-value ,object))))
114 `(let ,bindings ,form)
117 (defmacro accessor-slot-boundp (object slot-name)
118 (aver (constantp slot-name))
119 (let* ((slot-name (eval slot-name))
120 (boundp-name (slot-boundp-name slot-name)))
121 `(let ((.ignore. (load-time-value
122 (ensure-accessor 'boundp ',boundp-name ',slot-name))))
123 (declare (ignore .ignore.))
124 (funcall #',boundp-name ,object))))
126 (defun make-structure-slot-boundp-function (slotd)
127 (declare (ignore slotd))
129 (declare (ignore object))
132 (defun get-optimized-std-accessor-method-function (class slotd name)
134 ((structure-class-p class)
136 (reader (slot-definition-internal-reader-function slotd))
137 (writer (slot-definition-internal-writer-function slotd))
138 (boundp (make-structure-slot-boundp-function slotd))))
139 ((condition-class-p class)
141 (reader (slot-definition-reader-function slotd))
142 (writer (slot-definition-writer-function slotd))
143 (boundp (slot-definition-boundp-function slotd))))
145 (let* ((fsc-p (cond ((standard-class-p class) nil)
146 ((funcallable-standard-class-p class) t)
148 ;; Shouldn't be using the optimized-std-accessors
150 #+nil (format t "* warning: ~S ~S~% ~S~%"
153 (t (error "~S is not a STANDARD-CLASS." class))))
154 (slot-name (slot-definition-name slotd))
155 (index (slot-definition-location slotd))
156 (function (ecase name
157 (reader #'make-optimized-std-reader-method-function)
158 (writer #'make-optimized-std-writer-method-function)
159 (boundp #'make-optimized-std-boundp-method-function)))
160 (value (funcall function fsc-p slot-name index)))
161 (declare (type function function))
162 (values value index)))))
164 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
165 (declare #.*optimize-speed*)
170 (check-obsolete-instance instance)
171 (let ((value (clos-slots-ref (fsc-instance-slots instance)
173 (if (eq value +slot-unbound+)
174 (slot-unbound (class-of instance) instance slot-name)
177 (check-obsolete-instance instance)
178 (let ((value (clos-slots-ref (std-instance-slots instance)
180 (if (eq value +slot-unbound+)
181 (slot-unbound (class-of instance) instance slot-name)
183 (cons (lambda (instance)
184 (check-obsolete-instance instance)
185 (let ((value (cdr index)))
186 (if (eq value +slot-unbound+)
187 (slot-unbound (class-of instance) instance slot-name)
189 `(reader ,slot-name)))
191 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
192 (declare #.*optimize-speed*)
196 (lambda (nv instance)
197 (check-obsolete-instance instance)
198 (setf (clos-slots-ref (fsc-instance-slots instance) index)
200 (lambda (nv instance)
201 (check-obsolete-instance instance)
202 (setf (clos-slots-ref (std-instance-slots instance) index)
204 (cons (lambda (nv instance)
205 (check-obsolete-instance instance)
206 (setf (cdr index) nv))))
207 `(writer ,slot-name)))
209 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
210 (declare #.*optimize-speed*)
215 (check-obsolete-instance instance)
216 (not (eq (clos-slots-ref (fsc-instance-slots instance)
220 (check-obsolete-instance instance)
221 (not (eq (clos-slots-ref (std-instance-slots instance)
224 (cons (lambda (instance)
225 (check-obsolete-instance instance)
226 (not (eq (cdr index) +slot-unbound+)))))
227 `(boundp ,slot-name)))
229 (defun make-optimized-structure-slot-value-using-class-method-function (function)
230 (declare (type function function))
231 (lambda (class object slotd)
232 (declare (ignore class slotd))
233 (funcall function object)))
235 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
236 (declare (type function function))
237 (lambda (nv class object slotd)
238 (declare (ignore class slotd))
239 (funcall function nv object)))
241 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
242 (lambda (class object slotd)
243 (declare (ignore class object slotd))
246 (defun get-optimized-std-slot-value-using-class-method-function
249 ((structure-class-p class)
251 (reader (make-optimized-structure-slot-value-using-class-method-function
252 (slot-definition-internal-reader-function slotd)))
253 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
254 (slot-definition-internal-writer-function slotd)))
255 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
256 ((condition-class-p class)
259 (let ((fun (slot-definition-reader-function slotd)))
260 (declare (type function fun))
261 (lambda (class object slotd)
262 (declare (ignore class slotd))
263 (funcall fun object))))
265 (let ((fun (slot-definition-writer-function slotd)))
266 (declare (type function fun))
267 (lambda (new-value class object slotd)
268 (declare (ignore class slotd))
269 (funcall fun new-value object))))
271 (let ((fun (slot-definition-boundp-function slotd)))
272 (declare (type function fun))
273 (lambda (class object slotd)
274 (declare (ignore class slotd))
275 (funcall fun object))))))
277 (let* ((fsc-p (cond ((standard-class-p class) nil)
278 ((funcallable-standard-class-p class) t)
279 (t (error "~S is not a standard-class" class))))
280 (slot-name (slot-definition-name slotd))
281 (index (slot-definition-location slotd))
285 #'make-optimized-std-slot-value-using-class-method-function)
287 #'make-optimized-std-setf-slot-value-using-class-method-function)
289 #'make-optimized-std-slot-boundp-using-class-method-function))))
290 (declare (type function function))
291 (values (funcall function fsc-p slot-name index) index)))))
293 (defun make-optimized-std-slot-value-using-class-method-function
294 (fsc-p slot-name index)
295 (declare #.*optimize-speed*)
298 (lambda (class instance slotd)
299 (declare (ignore slotd))
300 (check-obsolete-instance instance)
301 (let ((value (clos-slots-ref (fsc-instance-slots instance)
303 (if (eq value +slot-unbound+)
304 (slot-unbound class instance slot-name)
306 (lambda (class instance slotd)
307 (declare (ignore slotd))
308 (check-obsolete-instance instance)
309 (let ((value (clos-slots-ref (std-instance-slots instance)
311 (if (eq value +slot-unbound+)
312 (slot-unbound class instance slot-name)
314 (cons (lambda (class instance slotd)
315 (declare (ignore slotd))
316 (check-obsolete-instance instance)
317 (let ((value (cdr index)))
318 (if (eq value +slot-unbound+)
319 (slot-unbound class instance slot-name)
322 (defun make-optimized-std-setf-slot-value-using-class-method-function
323 (fsc-p slot-name index)
324 (declare #.*optimize-speed*)
325 (declare (ignore slot-name))
328 (lambda (nv class instance slotd)
329 (declare (ignore class slotd))
330 (check-obsolete-instance instance)
331 (setf (clos-slots-ref (fsc-instance-slots instance) index)
333 (lambda (nv class instance slotd)
334 (declare (ignore class slotd))
335 (check-obsolete-instance instance)
336 (setf (clos-slots-ref (std-instance-slots instance) index)
338 (cons (lambda (nv class instance slotd)
339 (declare (ignore class slotd))
340 (check-obsolete-instance instance)
341 (setf (cdr index) nv)))))
343 (defun make-optimized-std-slot-boundp-using-class-method-function
344 (fsc-p slot-name index)
345 (declare #.*optimize-speed*)
346 (declare (ignore slot-name))
349 (lambda (class instance slotd)
350 (declare (ignore class slotd))
351 (check-obsolete-instance instance)
352 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
354 (lambda (class instance slotd)
355 (declare (ignore class slotd))
356 (check-obsolete-instance instance)
357 (not (eq (clos-slots-ref (std-instance-slots instance) index)
359 (cons (lambda (class instance slotd)
360 (declare (ignore class slotd))
361 (check-obsolete-instance instance)
362 (not (eq (cdr index) +slot-unbound+))))))
364 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
365 (macrolet ((emf-funcall (emf &rest args)
366 `(invoke-effective-method-function ,emf nil ,@args)))
369 (reader (lambda (instance)
370 (emf-funcall sdfun class instance slotd)))
371 (writer (lambda (nv instance)
372 (emf-funcall sdfun nv class instance slotd)))
373 (boundp (lambda (instance)
374 (emf-funcall sdfun class instance slotd))))
375 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
377 (defun make-internal-reader-method-function (class-name slot-name)
378 (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
379 (make-method-function
381 (let ((wrapper (get-instance-wrapper-or-nil instance)))
383 (let* ((class (wrapper-class* wrapper))
384 (index (or (instance-slot-index wrapper slot-name)
386 (wrapper-class-slots wrapper)))))
389 (let ((value (clos-slots-ref (get-slots instance)
391 (if (eq value +slot-unbound+)
392 (slot-unbound (class-of instance)
397 (let ((value (cdr index)))
398 (if (eq value +slot-unbound+)
399 (slot-unbound (class-of instance)
404 (error "~@<The wrapper for class ~S does not have ~
407 (slot-value instance slot-name)))))))
409 (defun make-std-reader-method-function (class-name slot-name)
410 (let* ((pv-table-symbol (gensym))
412 (make-method-function
414 (pv-binding1 (.pv. .calls.
415 (symbol-value pv-table-symbol)
416 (instance) (instance-slots))
417 (instance-read-internal
418 .pv. instance-slots 1
419 (slot-value instance slot-name))))))))
420 (setf (getf (getf initargs :plist) :slot-name-lists)
421 (list (list nil slot-name)))
422 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
423 (list* :method-spec `(reader-method ,class-name ,slot-name)
426 (defun make-std-writer-method-function (class-name slot-name)
427 (let* ((pv-table-symbol (gensym))
429 (make-method-function
430 (lambda (nv instance)
431 (pv-binding1 (.pv. .calls.
432 (symbol-value pv-table-symbol)
433 (instance) (instance-slots))
434 (instance-write-internal
435 .pv. instance-slots 1 nv
436 (setf (slot-value instance slot-name) nv))))))))
437 (setf (getf (getf initargs :plist) :slot-name-lists)
438 (list nil (list nil slot-name)))
439 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
440 (list* :method-spec `(writer-method ,class-name ,slot-name)
443 (defun make-std-boundp-method-function (class-name slot-name)
444 (let* ((pv-table-symbol (gensym))
446 (make-method-function
448 (pv-binding1 (.pv. .calls.
449 (symbol-value pv-table-symbol)
450 (instance) (instance-slots))
451 (instance-boundp-internal
452 .pv. instance-slots 1
453 (slot-boundp instance slot-name))))))))
454 (setf (getf (getf initargs :plist) :slot-name-lists)
455 (list (list nil slot-name)))
456 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
457 (list* :method-spec `(boundp-method ,class-name ,slot-name)
460 (defun initialize-internal-slot-gfs (slot-name &optional type)
461 (macrolet ((frob (type name-fun add-fun)
462 `(when (or (null type) (eq type ',type))
463 (let* ((name (,name-fun slot-name))
464 (gf (ensure-generic-function name))
465 (methods (generic-function-methods gf)))
466 (when (or (null methods)
467 (plist-value gf 'slot-missing-method))
468 (setf (plist-value gf 'slot-missing-method) nil)
469 (,add-fun *the-class-slot-object* gf slot-name))))))
470 (frob reader slot-reader-name add-reader-method)
471 (frob writer slot-writer-name add-writer-method)
472 (frob boundp slot-boundp-name add-boundp-method)))