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 quiet-funcall (fun &rest args)
60 ;; Don't give a style-warning about undefined function here.
61 `(funcall (locally (declare (muffle-conditions style-warning))
65 (defmacro accessor-slot-value (object slot-name &environment env)
66 (aver (constantp slot-name env))
67 (let* ((slot-name (constant-form-value slot-name env))
68 (reader-name (slot-reader-name slot-name)))
69 `(let ((.ignore. (load-time-value
70 (ensure-accessor 'reader ',reader-name ',slot-name))))
71 (declare (ignore .ignore.))
72 (truly-the (values t &optional)
73 (quiet-funcall #',reader-name ,object)))))
75 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
76 (aver (constantp slot-name env))
77 (setq object (macroexpand object env))
78 (let* ((slot-name (constant-form-value slot-name env))
79 (bind-object (unless (or (constantp new-value env) (atom new-value))
80 (let* ((object-var (gensym))
81 (bind `((,object-var ,object))))
82 (setf object object-var)
84 (writer-name (slot-writer-name slot-name))
88 (ensure-accessor 'writer ',writer-name ',slot-name)))
89 (.new-value. ,new-value))
90 (declare (ignore .ignore.))
91 (quiet-funcall #',writer-name .new-value. ,object)
94 `(let ,bind-object ,form)
97 (defmacro accessor-slot-boundp (object slot-name &environment env)
98 (aver (constantp slot-name env))
99 (let* ((slot-name (constant-form-value slot-name env))
100 (boundp-name (slot-boundp-name slot-name)))
101 `(let ((.ignore. (load-time-value
102 (ensure-accessor 'boundp ',boundp-name ',slot-name))))
103 (declare (ignore .ignore.))
104 (funcall #',boundp-name ,object))))
106 (defun make-structure-slot-boundp-function (slotd)
107 (declare (ignore slotd))
109 (declare (ignore object))
112 (define-condition instance-structure-protocol-error
113 (reference-condition error)
114 ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
115 (fun :initarg :fun :reader instance-structure-protocol-error-fun))
118 (format s "~@<The slot ~S has neither ~S nor ~S ~
119 allocation, so it can't be ~A by the default ~
121 (instance-structure-protocol-error-slotd c)
124 ((member (instance-structure-protocol-error-fun c)
125 '(slot-value-using-class slot-boundp-using-class))
128 (instance-structure-protocol-error-fun c)))))
130 (defun instance-structure-protocol-error (slotd fun)
131 (error 'instance-structure-protocol-error
132 :slotd slotd :fun fun
133 :references (list `(:amop :generic-function ,fun)
134 '(:amop :section (5 5 3)))))
136 (defun get-optimized-std-accessor-method-function (class slotd name)
138 ((structure-class-p class)
140 (reader (slot-definition-internal-reader-function slotd))
141 (writer (slot-definition-internal-writer-function slotd))
142 (boundp (make-structure-slot-boundp-function slotd))))
143 ((condition-class-p class)
145 (reader (slot-definition-reader-function slotd))
146 (writer (slot-definition-writer-function slotd))
147 (boundp (slot-definition-boundp-function slotd))))
149 (let* ((fsc-p (cond ((standard-class-p class) nil)
150 ((funcallable-standard-class-p class) t)
152 ;; Shouldn't be using the optimized-std-accessors
154 #+nil (format t "* warning: ~S ~S~% ~S~%"
157 (t (error "~S is not a STANDARD-CLASS." class))))
158 (slot-name (slot-definition-name slotd))
159 (location (slot-definition-location slotd))
160 (function (ecase name
161 (reader #'make-optimized-std-reader-method-function)
162 (writer #'make-optimized-std-writer-method-function)
163 (boundp #'make-optimized-std-boundp-method-function)))
164 ;; KLUDGE: we need this slightly hacky calling convention
165 ;; for these functions for bootstrapping reasons: see
166 ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR,
168 (value (funcall function fsc-p slotd slot-name location)))
169 (declare (type function function))
170 (values value (slot-definition-location slotd))))))
172 (defun make-optimized-std-reader-method-function
173 (fsc-p slotd slot-name location)
174 (declare #.*optimize-speed*)
180 (check-obsolete-instance instance)
181 (let ((value (clos-slots-ref (fsc-instance-slots instance)
183 (if (eq value +slot-unbound+)
185 (slot-unbound (class-of instance) instance slot-name))
188 (check-obsolete-instance instance)
189 (let ((value (clos-slots-ref (std-instance-slots instance)
191 (if (eq value +slot-unbound+)
193 (slot-unbound (class-of instance) instance slot-name))
197 (check-obsolete-instance instance)
198 (let ((value (cdr location)))
199 (if (eq value +slot-unbound+)
200 (values (slot-unbound (class-of instance) instance slot-name))
204 (instance-structure-protocol-error slotd 'slot-value-using-class))))
205 `(reader ,slot-name)))
207 (defun make-optimized-std-writer-method-function
208 (fsc-p slotd slot-name location)
209 (declare #.*optimize-speed*)
210 (let* ((safe-p (and slotd
211 (slot-definition-class slotd)
212 (safe-p (slot-definition-class slotd))))
213 (writer-fun (etypecase location
216 (lambda (nv instance)
217 (check-obsolete-instance instance)
218 (setf (clos-slots-ref (fsc-instance-slots instance)
221 (lambda (nv instance)
222 (check-obsolete-instance instance)
223 (setf (clos-slots-ref (std-instance-slots instance)
227 (lambda (nv instance)
228 (check-obsolete-instance instance)
229 (setf (cdr location) nv)))
231 (lambda (nv instance)
232 (declare (ignore nv instance))
233 (instance-structure-protocol-error
235 '(setf slot-value-using-class))))))
236 (checking-fun (lambda (new-value instance)
237 ;; If we have a TYPE-CHECK-FUNCTION, call it.
238 (let* (;; Note that the class of INSTANCE here is not
239 ;; neccessarily the SLOT-DEFINITION-CLASS of
240 ;; the SLOTD passed to M-O-S-W-M-F, since it's
241 ;; e.g. possible for a subclass to define a
242 ;; slot of the same name but with no accessors.
243 ;; So we need to fetch the right type check function
244 ;; from the wrapper instead of just closing over it.
245 (wrapper (valid-wrapper-of instance))
247 (cadr (find-slot-cell wrapper slot-name))))
248 (declare (type (or function null) type-check-function))
249 (when type-check-function
250 (funcall type-check-function new-value)))
251 ;; Then call the real writer.
252 (funcall writer-fun new-value instance))))
253 (set-fun-name (if safe-p
256 `(writer ,slot-name))))
258 (defun make-optimized-std-boundp-method-function
259 (fsc-p slotd slot-name location)
260 (declare #.*optimize-speed*)
265 (check-obsolete-instance instance)
266 (not (eq (clos-slots-ref (fsc-instance-slots instance)
270 (check-obsolete-instance instance)
271 (not (eq (clos-slots-ref (std-instance-slots instance)
274 (cons (lambda (instance)
275 (check-obsolete-instance instance)
276 (not (eq (cdr location) +slot-unbound+))))
279 (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
280 `(boundp ,slot-name)))
282 (defun make-optimized-structure-slot-value-using-class-method-function
284 (declare (type function function))
285 (lambda (class object slotd)
286 (declare (ignore class slotd))
287 (funcall function object)))
289 (defun make-optimized-structure-setf-slot-value-using-class-method-function
291 (declare (type function function))
292 (lambda (nv class object slotd)
293 (declare (ignore class slotd))
294 (funcall function nv object)))
296 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
297 (lambda (class object slotd)
298 (declare (ignore class object slotd))
301 (defun get-optimized-std-slot-value-using-class-method-function
304 ((structure-class-p class)
306 (reader (make-optimized-structure-slot-value-using-class-method-function
307 (slot-definition-internal-reader-function slotd)))
308 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
309 (slot-definition-internal-writer-function slotd)))
310 (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
311 ((condition-class-p class)
314 (let ((fun (slot-definition-reader-function slotd)))
315 (declare (type function fun))
316 (lambda (class object slotd)
317 (declare (ignore class slotd))
318 (funcall fun object))))
320 (let ((fun (slot-definition-writer-function slotd)))
321 (declare (type function fun))
322 (lambda (new-value class object slotd)
323 (declare (ignore class slotd))
324 (funcall fun new-value object))))
326 (let ((fun (slot-definition-boundp-function slotd)))
327 (declare (type function fun))
328 (lambda (class object slotd)
329 (declare (ignore class slotd))
330 (funcall fun object))))))
332 (let* ((fsc-p (cond ((standard-class-p class) nil)
333 ((funcallable-standard-class-p class) t)
334 (t (error "~S is not a standard-class" class))))
338 #'make-optimized-std-slot-value-using-class-method-function)
340 #'make-optimized-std-setf-slot-value-using-class-method-function)
342 #'make-optimized-std-slot-boundp-using-class-method-function))))
343 (declare (type function function))
344 (values (funcall function fsc-p slotd)
345 (slot-definition-location slotd))))))
347 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
348 (declare #.*optimize-speed*)
349 (let ((location (slot-definition-location slotd))
350 (slot-name (slot-definition-name slotd)))
353 (lambda (class instance slotd)
354 (declare (ignore slotd))
355 (check-obsolete-instance instance)
356 (let ((value (clos-slots-ref (fsc-instance-slots instance)
358 (if (eq value +slot-unbound+)
359 (values (slot-unbound class instance slot-name))
361 (lambda (class instance slotd)
362 (declare (ignore slotd))
363 (check-obsolete-instance instance)
364 (let ((value (clos-slots-ref (std-instance-slots instance)
366 (if (eq value +slot-unbound+)
367 (values (slot-unbound class instance slot-name))
369 (cons (lambda (class instance slotd)
370 (declare (ignore slotd))
371 (check-obsolete-instance instance)
372 (let ((value (cdr location)))
373 (if (eq value +slot-unbound+)
374 (values (slot-unbound class instance slot-name))
377 (lambda (class instance slotd)
378 (declare (ignore class instance))
379 (instance-structure-protocol-error slotd 'slot-value-using-class))))))
381 (defun make-optimized-std-setf-slot-value-using-class-method-function
383 (declare #.*optimize-speed*)
384 (let ((location (slot-definition-location slotd))
387 (slot-definition-class slotd)
388 (safe-p (slot-definition-class slotd)))
389 (slot-definition-type-check-function slotd))))
390 (macrolet ((make-mf-lambda (&body body)
391 `(lambda (nv class instance slotd)
392 (declare (ignore class slotd))
393 (check-obsolete-instance instance)
395 (make-mf-lambdas (&body body)
396 ;; Having separate lambdas for the NULL / not-NULL cases of
397 ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
398 ;; for CLOS typechecking when it's not in use.
399 `(if type-check-function
401 (funcall (the function type-check-function) nv)
409 (setf (clos-slots-ref (fsc-instance-slots instance) location)
412 (setf (clos-slots-ref (std-instance-slots instance) location)
415 (make-mf-lambdas (setf (cdr location) nv)))
416 (null (lambda (nv class instance slotd)
417 (declare (ignore nv class instance))
418 (instance-structure-protocol-error
419 slotd '(setf slot-value-using-class))))))))
421 (defun make-optimized-std-slot-boundp-using-class-method-function
423 (declare #.*optimize-speed*)
424 (let ((location (slot-definition-location slotd)))
428 (lambda (class instance slotd)
429 (declare (ignore class slotd))
430 (check-obsolete-instance instance)
431 (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
433 (lambda (class instance slotd)
434 (declare (ignore class slotd))
435 (check-obsolete-instance instance)
436 (not (eq (clos-slots-ref (std-instance-slots instance) location)
438 (cons (lambda (class instance slotd)
439 (declare (ignore class slotd))
440 (check-obsolete-instance instance)
441 (not (eq (cdr location) +slot-unbound+))))
443 (lambda (class instance slotd)
444 (declare (ignore class instance))
445 (instance-structure-protocol-error slotd
446 'slot-boundp-using-class))))))
448 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
449 (macrolet ((emf-funcall (emf &rest args)
450 `(invoke-effective-method-function ,emf nil
451 :required-args ,args)))
454 (reader (lambda (instance)
455 (emf-funcall sdfun class instance slotd)))
456 (writer (lambda (nv instance)
457 (emf-funcall sdfun nv class instance slotd)))
458 (boundp (lambda (instance)
459 (emf-funcall sdfun class instance slotd))))
460 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
462 (defun make-std-reader-method-function (class-or-name slot-name)
463 (declare (ignore class-or-name))
464 (let* ((initargs (copy-tree
465 (make-method-function
467 (pv-binding1 ((bug "Please report this")
468 (instance) (instance-slots))
469 (instance-read-internal
470 .pv. instance-slots 0
471 (slot-value instance slot-name))))))))
472 (setf (getf (getf initargs 'plist) :slot-name-lists)
473 (list (list nil slot-name)))
476 (defun make-std-writer-method-function (class-or-name slot-name)
477 (let* ((class (when (eq **boot-state** 'complete)
478 (if (typep class-or-name 'class)
480 (find-class class-or-name nil))))
483 (check-fun (lambda (new-value instance)
484 (let* ((class (class-of instance))
485 (slotd (find-slot-definition class slot-name))
488 (slot-definition-type-check-function slotd))))
489 (when type-check-function
490 (funcall type-check-function new-value)))))
493 (make-method-function
494 (lambda (nv instance)
495 (funcall check-fun nv instance)
496 (pv-binding1 ((bug "Please report this")
497 (instance) (instance-slots))
498 (instance-write-internal
499 .pv. instance-slots 0 nv
500 (setf (slot-value instance slot-name) nv)))))
501 (make-method-function
502 (lambda (nv instance)
503 (pv-binding1 ((bug "Please report this")
504 (instance) (instance-slots))
505 (instance-write-internal
506 .pv. instance-slots 0 nv
507 (setf (slot-value instance slot-name) nv)))))))))
508 (setf (getf (getf initargs 'plist) :slot-name-lists)
509 (list nil (list nil slot-name)))
512 (defun make-std-boundp-method-function (class-or-name slot-name)
513 (declare (ignore class-or-name))
514 (let* ((initargs (copy-tree
515 (make-method-function
517 (pv-binding1 ((bug "Please report this")
518 (instance) (instance-slots))
519 (instance-boundp-internal
520 .pv. instance-slots 0
521 (slot-boundp instance slot-name))))))))
522 (setf (getf (getf initargs 'plist) :slot-name-lists)
523 (list (list nil slot-name)))
526 ;;;; FINDING SLOT DEFINITIONS
528 ;;; Historical PCL found slot definitions by iterating over
529 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
530 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
531 ;;; list up to the desired one.
533 ;;; Current SBCL hashes the effective slot definitions, and some
534 ;;; information pulled out from them into a simple-vector, with bucket
535 ;;; chains made out of plists keyed by the slot names. This fixes
536 ;;; gives O(1) performance, and avoid the GF calls.
538 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
539 ;;; effective slot definitions and the class they pertain to, and
540 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
542 ;;; The only bit of cleverness in the implementation is to make the
543 ;;; vectors fairly tight, but always longer then 0 elements:
545 ;;; -- We don't want to waste huge amounts of space no these vectors,
546 ;;; which are mostly required by things like SLOT-VALUE with a
547 ;;; variable slot name, so a constant extension over the minimum
548 ;;; size seems like a good choise.
550 ;;; -- As long as the vector always has a length > 0
551 ;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
552 ;;; empty vector separately: it just returns a NIL.
554 ;;; In addition to the slot-definition we also store the slot-location
555 ;;; and type-check function for instances of standard metaclasses, so
556 ;;; that SLOT-VALUE &co using variable slot names can get at them
557 ;;; without additional GF calls.
560 ;;; It would be probably better to store the vector in wrapper
561 ;;; instead: one less memory indirection, one less CLOS slot
562 ;;; access to get at it.
564 ;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
565 ;;; generic instead of checking versus STANDARD-CLASS and
566 ;;; FUNCALLABLE-STANDARD-CLASS.
568 (defun find-slot-definition (class slot-name)
569 (dolist (slotd (class-slots class))
570 (when (eq slot-name (slot-definition-name slotd))
573 (defun find-slot-cell (wrapper slot-name)
574 (declare (symbol slot-name))
575 (let* ((vector (layout-slot-table wrapper))
576 (index (rem (sxhash slot-name) (length vector))))
577 (declare (simple-vector vector) (index index)
578 (optimize (sb-c::insert-array-bounds-checks 0)))
579 (do ((plist (the list (svref vector index)) (cdr plist)))
580 ((not (consp plist)))
581 (let ((key (car plist)))
582 (setf plist (cdr plist))
583 (when (eq key slot-name)
584 (return (car plist)))))))
586 (defun make-slot-table (class slots &optional bootstrap)
587 (let* ((n (+ (length slots) 2))
588 (vector (make-array n :initial-element nil))
589 (save-slot-location-p
591 (when (eq 'complete **boot-state**)
592 (let ((metaclass (class-of class)))
593 (or (eq metaclass *the-class-standard-class*)
594 (eq metaclass *the-class-funcallable-standard-class*))))))
595 (save-type-check-function-p
597 (and (eq 'complete **boot-state**) (safe-p class)))))
598 (flet ((add-to-vector (name slot)
599 (declare (symbol name)
600 (optimize (sb-c::insert-array-bounds-checks 0)))
601 (let ((index (rem (sxhash name) n)))
602 (setf (svref vector index)
603 (list* name (list* (when save-slot-location-p
605 (early-slot-definition-location slot)
606 (slot-definition-location slot)))
607 (when save-type-check-function-p
608 (slot-definition-type-check-function slot))
610 (svref vector index))))))
611 (if (eq 'complete **boot-state**)
613 (add-to-vector (slot-definition-name slot) slot))
615 (add-to-vector (early-slot-definition-name slot) slot))))