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 (let ((reader-specializers '(slot-object))
27 (writer-specializers '(t slot-object)))
28 (defun ensure-accessor (type fun-name slot-name)
29 (unless (fboundp fun-name)
30 (multiple-value-bind (lambda-list specializers method-class initargs doc)
32 ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
33 ;; behaviour for non-slot-objects too?
35 (values '(object) reader-specializers 'global-reader-method
36 (make-std-reader-method-function 'slot-object slot-name)
37 "automatically-generated reader method"))
39 (values '(new-value object) writer-specializers
41 (make-std-writer-method-function 'slot-object slot-name)
42 "automatically-generated writer method"))
44 (values '(object) reader-specializers 'global-boundp-method
45 (make-std-boundp-method-function 'slot-object slot-name)
46 "automatically-generated boundp method")))
47 (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
48 (add-method gf (make-a-method method-class
49 () lambda-list specializers
50 initargs doc :slot-name slot-name)))))
52 ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented
53 ;; by CSR in June 2007. Making the bootstrap sane is getting higher
54 ;; on the "TODO: URGENT" list.
55 (defun !fix-ensure-accessor-specializers ()
56 (setf reader-specializers (mapcar #'find-class reader-specializers))
57 (setf writer-specializers (mapcar #'find-class writer-specializers))))
59 (defmacro accessor-slot-value (object slot-name)
60 (aver (constantp slot-name))
61 (let* ((slot-name (constant-form-value slot-name))
62 (reader-name (slot-reader-name slot-name)))
63 `(let ((.ignore. (load-time-value
64 (ensure-accessor 'reader ',reader-name ',slot-name))))
65 (declare (ignore .ignore.))
66 (truly-the (values t &optional)
67 (funcall #',reader-name ,object)))))
69 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
70 (aver (constantp slot-name))
71 (setq object (macroexpand object env))
72 (setq slot-name (macroexpand slot-name env))
73 (let* ((slot-name (constant-form-value slot-name))
74 (bindings (unless (or (constantp new-value) (atom new-value))
75 (let ((object-var (gensym)))
76 (prog1 `((,object-var ,object))
77 (setq object object-var)))))
78 (writer-name (slot-writer-name slot-name))
82 (ensure-accessor 'writer ',writer-name ',slot-name)))
83 (.new-value. ,new-value))
84 (declare (ignore .ignore.))
85 (funcall #',writer-name .new-value. ,object)
88 `(let ,bindings ,form)
91 (defmacro accessor-slot-boundp (object slot-name)
92 (aver (constantp slot-name))
93 (let* ((slot-name (constant-form-value slot-name))
94 (boundp-name (slot-boundp-name slot-name)))
95 `(let ((.ignore. (load-time-value
96 (ensure-accessor 'boundp ',boundp-name ',slot-name))))
97 (declare (ignore .ignore.))
98 (funcall #',boundp-name ,object))))
100 (defun make-structure-slot-boundp-function (slotd)
101 (declare (ignore slotd))
103 (declare (ignore object))
106 (define-condition instance-structure-protocol-error
107 (reference-condition error)
108 ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
109 (fun :initarg :fun :reader instance-structure-protocol-error-fun))
112 (format s "~@<The slot ~S has neither ~S nor ~S ~
113 allocation, so it can't be ~A by the default ~
115 (instance-structure-protocol-error-slotd c)
118 ((member (instance-structure-protocol-error-fun c)
119 '(slot-value-using-class slot-boundp-using-class))
122 (instance-structure-protocol-error-fun c)))))
124 (defun instance-structure-protocol-error (slotd fun)
125 (error 'instance-structure-protocol-error
126 :slotd slotd :fun fun
127 :references (list `(:amop :generic-function ,fun)
128 '(:amop :section (5 5 3)))))
130 (defun get-optimized-std-accessor-method-function (class slotd name)
132 ((structure-class-p class)
134 (reader (slot-definition-internal-reader-function slotd))
135 (writer (slot-definition-internal-writer-function slotd))
136 (boundp (make-structure-slot-boundp-function slotd))))
137 ((condition-class-p class)
139 (reader (slot-definition-reader-function slotd))
140 (writer (slot-definition-writer-function slotd))
141 (boundp (slot-definition-boundp-function slotd))))
143 (let* ((fsc-p (cond ((standard-class-p class) nil)
144 ((funcallable-standard-class-p class) t)
146 ;; Shouldn't be using the optimized-std-accessors
148 #+nil (format t "* warning: ~S ~S~% ~S~%"
151 (t (error "~S is not a STANDARD-CLASS." class))))
152 (slot-name (slot-definition-name slotd))
153 (location (slot-definition-location slotd))
154 (function (ecase name
155 (reader #'make-optimized-std-reader-method-function)
156 (writer #'make-optimized-std-writer-method-function)
157 (boundp #'make-optimized-std-boundp-method-function)))
158 ;; KLUDGE: we need this slightly hacky calling convention
159 ;; for these functions for bootstrapping reasons: see
160 ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR,
162 (value (funcall function fsc-p slotd slot-name location)))
163 (declare (type function function))
164 (values value (slot-definition-location slotd))))))
166 (defun make-optimized-std-reader-method-function
167 (fsc-p slotd slot-name location)
168 (declare #.*optimize-speed*)
174 (check-obsolete-instance instance)
175 (let ((value (clos-slots-ref (fsc-instance-slots instance)
177 (if (eq value +slot-unbound+)
179 (slot-unbound (class-of instance) instance slot-name))
182 (check-obsolete-instance instance)
183 (let ((value (clos-slots-ref (std-instance-slots instance)
185 (if (eq value +slot-unbound+)
187 (slot-unbound (class-of instance) instance slot-name))
191 (check-obsolete-instance instance)
192 (let ((value (cdr location)))
193 (if (eq value +slot-unbound+)
194 (values (slot-unbound (class-of instance) instance slot-name))
198 (instance-structure-protocol-error slotd 'slot-value-using-class))))
199 `(reader ,slot-name)))
201 (defun make-optimized-std-writer-method-function
202 (fsc-p slotd slot-name location)
203 (declare #.*optimize-speed*)
204 (let* ((safe-p (and slotd
205 (slot-definition-class slotd)
206 (safe-p (slot-definition-class slotd))))
207 (writer-fun (etypecase location
209 (lambda (nv instance)
210 (check-obsolete-instance instance)
211 (setf (clos-slots-ref (fsc-instance-slots instance)
214 (lambda (nv instance)
215 (check-obsolete-instance instance)
216 (setf (clos-slots-ref (std-instance-slots instance)
219 (cons (lambda (nv instance)
220 (check-obsolete-instance instance)
221 (setf (cdr location) nv)))
223 (lambda (nv instance)
224 (declare (ignore nv instance))
225 (instance-structure-protocol-error
227 '(setf slot-value-using-class))))))
228 (checking-fun (lambda (new-value instance)
229 (check-obsolete-instance instance)
230 ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
231 (let* (;; Note that this CLASS is not neccessarily
232 ;; the SLOT-DEFINITION-CLASS of the
233 ;; SLOTD passed to M-O-S-W-M-F, since it's
234 ;; e.g. possible for a subclass to define
235 ;; a slot of the same name but with no
236 ;; accessors. So we need to fetch the SLOTD
237 ;; when CHECKING-FUN is called, instead of
238 ;; just closing over it.
239 (class (class-of instance))
240 (slotd (find-slot-definition class slot-name))
243 (slot-definition-type-check-function slotd))))
244 (when type-check-function
245 (funcall type-check-function new-value)))
246 ;; Then call the real writer.
247 (funcall writer-fun new-value instance))))
248 (set-fun-name (if safe-p
251 `(writer ,slot-name))))
253 (defun make-optimized-std-boundp-method-function
254 (fsc-p slotd slot-name location)
255 (declare #.*optimize-speed*)
260 (check-obsolete-instance instance)
261 (not (eq (clos-slots-ref (fsc-instance-slots instance)
265 (check-obsolete-instance instance)
266 (not (eq (clos-slots-ref (std-instance-slots instance)
269 (cons (lambda (instance)
270 (check-obsolete-instance instance)
271 (not (eq (cdr location) +slot-unbound+))))
274 (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
275 `(boundp ,slot-name)))
277 (defun make-optimized-structure-slot-value-using-class-method-function
279 (declare (type function function))
280 (lambda (class object slotd)
281 (declare (ignore class slotd))
282 (funcall function object)))
284 (defun make-optimized-structure-setf-slot-value-using-class-method-function
286 (declare (type function function))
287 (lambda (nv class object slotd)
288 (declare (ignore class slotd))
289 (funcall function nv object)))
291 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
292 (lambda (class object slotd)
293 (declare (ignore class object slotd))
296 (defun get-optimized-std-slot-value-using-class-method-function
299 ((structure-class-p class)
301 (reader (make-optimized-structure-slot-value-using-class-method-function
302 (slot-definition-internal-reader-function slotd)))
303 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
304 (slot-definition-internal-writer-function slotd)))
305 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
306 ((condition-class-p class)
309 (let ((fun (slot-definition-reader-function slotd)))
310 (declare (type function fun))
311 (lambda (class object slotd)
312 (declare (ignore class slotd))
313 (funcall fun object))))
315 (let ((fun (slot-definition-writer-function slotd)))
316 (declare (type function fun))
317 (lambda (new-value class object slotd)
318 (declare (ignore class slotd))
319 (funcall fun new-value object))))
321 (let ((fun (slot-definition-boundp-function slotd)))
322 (declare (type function fun))
323 (lambda (class object slotd)
324 (declare (ignore class slotd))
325 (funcall fun object))))))
327 (let* ((fsc-p (cond ((standard-class-p class) nil)
328 ((funcallable-standard-class-p class) t)
329 (t (error "~S is not a standard-class" class))))
333 #'make-optimized-std-slot-value-using-class-method-function)
335 #'make-optimized-std-setf-slot-value-using-class-method-function)
337 #'make-optimized-std-slot-boundp-using-class-method-function))))
338 (declare (type function function))
339 (values (funcall function fsc-p slotd)
340 (slot-definition-location slotd))))))
342 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
343 (declare #.*optimize-speed*)
344 (let ((location (slot-definition-location slotd))
345 (slot-name (slot-definition-name slotd)))
348 (lambda (class instance slotd)
349 (declare (ignore slotd))
350 (check-obsolete-instance instance)
351 (let ((value (clos-slots-ref (fsc-instance-slots instance)
353 (if (eq value +slot-unbound+)
354 (values (slot-unbound class instance slot-name))
356 (lambda (class instance slotd)
357 (declare (ignore slotd))
358 (check-obsolete-instance instance)
359 (let ((value (clos-slots-ref (std-instance-slots instance)
361 (if (eq value +slot-unbound+)
362 (values (slot-unbound class instance slot-name))
364 (cons (lambda (class instance slotd)
365 (declare (ignore slotd))
366 (check-obsolete-instance instance)
367 (let ((value (cdr location)))
368 (if (eq value +slot-unbound+)
369 (values (slot-unbound class instance slot-name))
372 (lambda (class instance slotd)
373 (declare (ignore class instance))
374 (instance-structure-protocol-error slotd 'slot-value-using-class))))))
376 (defun make-optimized-std-setf-slot-value-using-class-method-function
378 (declare #.*optimize-speed*)
379 (let ((location (slot-definition-location slotd))
382 (slot-definition-class slotd)
383 (safe-p (slot-definition-class slotd)))
384 (slot-definition-type-check-function slotd))))
385 (macrolet ((make-mf-lambda (&body body)
386 `(lambda (nv class instance slotd)
387 (declare (ignore class slotd))
388 (check-obsolete-instance instance)
390 (make-mf-lambdas (&body body)
391 ;; Having separate lambdas for the NULL / not-NULL cases of
392 ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
393 ;; for CLOS typechecking when it's not in use.
394 `(if type-check-function
396 (funcall (the function type-check-function) nv)
404 (setf (clos-slots-ref (fsc-instance-slots instance) location)
407 (setf (clos-slots-ref (std-instance-slots instance) location)
410 (make-mf-lambdas (setf (cdr location) nv)))
411 (null (lambda (nv class instance slotd)
412 (declare (ignore nv class instance))
413 (instance-structure-protocol-error
414 slotd '(setf slot-value-using-class))))))))
416 (defun make-optimized-std-slot-boundp-using-class-method-function
418 (declare #.*optimize-speed*)
419 (let ((location (slot-definition-location slotd)))
423 (lambda (class instance slotd)
424 (declare (ignore class slotd))
425 (check-obsolete-instance instance)
426 (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
428 (lambda (class instance slotd)
429 (declare (ignore class slotd))
430 (check-obsolete-instance instance)
431 (not (eq (clos-slots-ref (std-instance-slots instance) location)
433 (cons (lambda (class instance slotd)
434 (declare (ignore class slotd))
435 (check-obsolete-instance instance)
436 (not (eq (cdr location) +slot-unbound+))))
438 (lambda (class instance slotd)
439 (declare (ignore class instance))
440 (instance-structure-protocol-error slotd
441 'slot-boundp-using-class))))))
443 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
444 (macrolet ((emf-funcall (emf &rest args)
445 `(invoke-effective-method-function ,emf nil
446 :required-args ,args)))
449 (reader (lambda (instance)
450 (emf-funcall sdfun class instance slotd)))
451 (writer (lambda (nv instance)
452 (emf-funcall sdfun nv class instance slotd)))
453 (boundp (lambda (instance)
454 (emf-funcall sdfun class instance slotd))))
455 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
457 (defun make-std-reader-method-function (class-or-name slot-name)
458 (declare (ignore class-or-name))
459 (let* ((initargs (copy-tree
460 (make-method-function
462 (pv-binding1 (.pv. .calls.
463 (bug "Please report this")
464 (instance) (instance-slots))
465 (instance-read-internal
466 .pv. instance-slots 0
467 (slot-value instance slot-name))))))))
468 (setf (getf (getf initargs 'plist) :slot-name-lists)
469 (list (list nil slot-name)))
472 (defun make-std-writer-method-function (class-or-name slot-name)
473 (let* ((class (when (eq *boot-state* 'complete)
474 (if (typep class-or-name 'class)
476 (find-class class-or-name nil))))
479 (check-fun (lambda (new-value instance)
480 (let* ((class (class-of instance))
481 (slotd (find-slot-definition class slot-name))
484 (slot-definition-type-check-function slotd))))
485 (when type-check-function
486 (funcall type-check-function new-value)))))
489 (make-method-function
490 (lambda (nv instance)
491 (funcall check-fun nv instance)
492 (pv-binding1 (.pv. .calls.
493 (bug "Please report this")
494 (instance) (instance-slots))
495 (instance-write-internal
496 .pv. instance-slots 0 nv
497 (setf (slot-value instance slot-name) nv)))))
498 (make-method-function
499 (lambda (nv instance)
500 (pv-binding1 (.pv. .calls.
501 (bug "Please report this")
502 (instance) (instance-slots))
503 (instance-write-internal
504 .pv. instance-slots 0 nv
505 (setf (slot-value instance slot-name) nv)))))))))
506 (setf (getf (getf initargs 'plist) :slot-name-lists)
507 (list nil (list nil slot-name)))
510 (defun make-std-boundp-method-function (class-or-name slot-name)
511 (declare (ignore class-or-name))
512 (let* ((initargs (copy-tree
513 (make-method-function
515 (pv-binding1 (.pv. .calls.
516 (bug "Please report this")
517 (instance) (instance-slots))
518 (instance-boundp-internal
519 .pv. instance-slots 0
520 (slot-boundp instance slot-name))))))))
521 (setf (getf (getf initargs 'plist) :slot-name-lists)
522 (list (list nil slot-name)))