src/pcl/slots-boot.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   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
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  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
  18 ;;;; control laws.
  19 ;;;;
  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
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  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)
  31           (ecase type
  32             ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
  33             ;; behaviour for non-slot-objects too?
  34             (reader
  35              (values '(object) reader-specializers 'global-reader-method
  36                      (make-std-reader-method-function 'slot-object slot-name)
  37                      "automatically-generated reader method"))
  38             (writer
  39              (values '(new-value object) writer-specializers
  40                      'global-writer-method
  41                      (make-std-writer-method-function 'slot-object slot-name)
  42                      "automatically-generated writer method"))
  43             (boundp
  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)))))
  51     t)
  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))))
  58
  59 (defmacro accessor-slot-value (object slot-name &environment env)
  60   (aver (constantp slot-name env))
  61   (let* ((slot-name (constant-form-value slot-name env))
  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                  ;; Don't give a style-warning about undefined function here.
  68                  (funcall (locally (declare (muffle-conditions style-warning))
  69                             #',reader-name)
  70                           ,object)))))
  71
  72 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  73   (aver (constantp slot-name env))
  74   (setq object (macroexpand object env))
  75   (let* ((slot-name (constant-form-value slot-name env))
  76          (bind-object (unless (or (constantp new-value env) (atom new-value))
  77                         (let* ((object-var (gensym))
  78                                (bind `((,object-var ,object))))
  79                           (setf object object-var)
  80                           bind)))
  81          (writer-name (slot-writer-name slot-name))
  82          (form
  83           `(let ((.ignore.
  84                   (load-time-value
  85                    (ensure-accessor 'writer ',writer-name ',slot-name)))
  86                  (.new-value. ,new-value))
  87             (declare (ignore .ignore.))
  88             (funcall #',writer-name .new-value. ,object)
  89             .new-value.)))
  90     (if bind-object
  91         `(let ,bind-object ,form)
  92         form)))
  93
  94 (defmacro accessor-slot-boundp (object slot-name &environment env)
  95   (aver (constantp slot-name env))
  96   (let* ((slot-name (constant-form-value slot-name env))
  97          (boundp-name (slot-boundp-name slot-name)))
  98     `(let ((.ignore. (load-time-value
  99                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
 100       (declare (ignore .ignore.))
 101       (funcall #',boundp-name ,object))))
 102
 103 (defun make-structure-slot-boundp-function (slotd)
 104   (declare (ignore slotd))
 105   (lambda (object)
 106     (declare (ignore object))
 107     t))
 108
 109 (define-condition instance-structure-protocol-error
 110     (reference-condition error)
 111   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
 112    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
 113   (:report
 114    (lambda (c s)
 115      (format s "~@<The slot ~S has neither ~S nor ~S ~
 116                 allocation, so it can't be ~A by the default ~
 117                 ~S method.~@:>"
 118              (instance-structure-protocol-error-slotd c)
 119              :instance :class
 120              (cond
 121                ((member (instance-structure-protocol-error-fun c)
 122                         '(slot-value-using-class slot-boundp-using-class))
 123                 "read")
 124                (t "written"))
 125              (instance-structure-protocol-error-fun c)))))
 126
 127 (defun instance-structure-protocol-error (slotd fun)
 128   (error 'instance-structure-protocol-error
 129          :slotd slotd :fun fun
 130          :references (list `(:amop :generic-function ,fun)
 131                            '(:amop :section (5 5 3)))))
 132
 133 (defun get-optimized-std-accessor-method-function (class slotd name)
 134   (cond
 135     ((structure-class-p class)
 136      (ecase name
 137        (reader (slot-definition-internal-reader-function slotd))
 138        (writer (slot-definition-internal-writer-function slotd))
 139        (boundp (make-structure-slot-boundp-function slotd))))
 140     ((condition-class-p class)
 141      (ecase name
 142        (reader (slot-definition-reader-function slotd))
 143        (writer (slot-definition-writer-function slotd))
 144        (boundp (slot-definition-boundp-function slotd))))
 145     (t
 146      (let* ((fsc-p (cond ((standard-class-p class) nil)
 147                          ((funcallable-standard-class-p class) t)
 148                          ((std-class-p class)
 149                           ;; Shouldn't be using the optimized-std-accessors
 150                           ;; in this case.
 151                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 152                                         name slotd class)
 153                           nil)
 154                          (t (error "~S is not a STANDARD-CLASS." class))))
 155             (slot-name (slot-definition-name slotd))
 156             (location (slot-definition-location slotd))
 157             (function (ecase name
 158                         (reader #'make-optimized-std-reader-method-function)
 159                         (writer #'make-optimized-std-writer-method-function)
 160                         (boundp #'make-optimized-std-boundp-method-function)))
 161             ;; KLUDGE: we need this slightly hacky calling convention
 162             ;; for these functions for bootstrapping reasons: see
 163             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 164             ;; 2004-07-12
 165             (value (funcall function fsc-p slotd slot-name location)))
 166        (declare (type function function))
 167        (values value (slot-definition-location slotd))))))
 168
 169 (defun make-optimized-std-reader-method-function
 170     (fsc-p slotd slot-name location)
 171   (declare #.*optimize-speed*)
 172   (set-fun-name
 173    (etypecase location
 174      (fixnum
 175       (if fsc-p
 176           (lambda (instance)
 177             (check-obsolete-instance instance)
 178             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 179                                          location)))
 180               (if (eq value +slot-unbound+)
 181                   (values
 182                    (slot-unbound (class-of instance) instance slot-name))
 183                   value)))
 184           (lambda (instance)
 185             (check-obsolete-instance instance)
 186             (let ((value (clos-slots-ref (std-instance-slots instance)
 187                                          location)))
 188               (if (eq value +slot-unbound+)
 189                   (values
 190                    (slot-unbound (class-of instance) instance slot-name))
 191                   value)))))
 192      (cons
 193       (lambda (instance)
 194         (check-obsolete-instance instance)
 195         (let ((value (cdr location)))
 196           (if (eq value +slot-unbound+)
 197               (values (slot-unbound (class-of instance) instance slot-name))
 198               value))))
 199      (null
 200       (lambda (instance)
 201         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 202    `(reader ,slot-name)))
 203
 204 (defun make-optimized-std-writer-method-function
 205     (fsc-p slotd slot-name location)
 206   (declare #.*optimize-speed*)
 207   (let* ((safe-p (and slotd
 208                       (slot-definition-class slotd)
 209                       (safe-p (slot-definition-class slotd))))
 210          (writer-fun (etypecase location
 211                        (fixnum
 212                         (if fsc-p
 213                             (lambda (nv instance)
 214                               (check-obsolete-instance instance)
 215                               (setf (clos-slots-ref (fsc-instance-slots instance)
 216                                                     location)
 217                                     nv))
 218                             (lambda (nv instance)
 219                               (check-obsolete-instance instance)
 220                               (setf (clos-slots-ref (std-instance-slots instance)
 221                                                     location)
 222                                     nv))))
 223                        (cons
 224                         (lambda (nv instance)
 225                           (check-obsolete-instance instance)
 226                           (setf (cdr location) nv)))
 227                        (null
 228                         (lambda (nv instance)
 229                           (declare (ignore nv instance))
 230                           (instance-structure-protocol-error
 231                            slotd
 232                            '(setf slot-value-using-class))))))
 233          (checking-fun (lambda (new-value instance)
 234                          ;; If we have a TYPE-CHECK-FUNCTION, call it.
 235                          (let* (;; Note that the class of INSTANCE here is not
 236                                 ;; neccessarily the SLOT-DEFINITION-CLASS of
 237                                 ;; the SLOTD passed to M-O-S-W-M-F, since it's
 238                                 ;; e.g. possible for a subclass to define a
 239                                 ;; slot of the same name but with no accessors.
 240                                 ;; So we need to fetch the right type check function
 241                                 ;; from the wrapper instead of just closing over it.
 242                                 (wrapper (valid-wrapper-of instance))
 243                                 (type-check-function
 244                                  (cadr (find-slot-cell wrapper slot-name))))
 245                            (declare (type (or function null) type-check-function))
 246                            (when type-check-function
 247                              (funcall type-check-function new-value)))
 248                          ;; Then call the real writer.
 249                          (funcall writer-fun new-value instance))))
 250     (set-fun-name (if safe-p
 251                       checking-fun
 252                       writer-fun)
 253                   `(writer ,slot-name))))
 254
 255 (defun make-optimized-std-boundp-method-function
 256     (fsc-p slotd slot-name location)
 257   (declare #.*optimize-speed*)
 258   (set-fun-name
 259    (etypecase location
 260      (fixnum (if fsc-p
 261                  (lambda (instance)
 262                    (check-obsolete-instance instance)
 263                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 264                                             location)
 265                             +slot-unbound+)))
 266                  (lambda (instance)
 267                    (check-obsolete-instance instance)
 268                    (not (eq (clos-slots-ref (std-instance-slots instance)
 269                                             location)
 270                             +slot-unbound+)))))
 271      (cons (lambda (instance)
 272              (check-obsolete-instance instance)
 273              (not (eq (cdr location) +slot-unbound+))))
 274      (null
 275       (lambda (instance)
 276         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 277    `(boundp ,slot-name)))
 278
 279 (defun make-optimized-structure-slot-value-using-class-method-function
 280     (function)
 281   (declare (type function function))
 282   (lambda (class object slotd)
 283     (declare (ignore class slotd))
 284     (funcall function object)))
 285
 286 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 287     (function)
 288   (declare (type function function))
 289   (lambda (nv class object slotd)
 290     (declare (ignore class slotd))
 291     (funcall function nv object)))
 292
 293 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 294   (lambda (class object slotd)
 295     (declare (ignore class object slotd))
 296     t))
 297
 298 (defun get-optimized-std-slot-value-using-class-method-function
 299     (class slotd name)
 300   (cond
 301     ((structure-class-p class)
 302      (ecase name
 303        (reader (make-optimized-structure-slot-value-using-class-method-function
 304                 (slot-definition-internal-reader-function slotd)))
 305        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 306                 (slot-definition-internal-writer-function slotd)))
 307        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
 308     ((condition-class-p class)
 309      (ecase name
 310        (reader
 311         (let ((fun (slot-definition-reader-function slotd)))
 312           (declare (type function fun))
 313           (lambda (class object slotd)
 314             (declare (ignore class slotd))
 315             (funcall fun object))))
 316        (writer
 317         (let ((fun (slot-definition-writer-function slotd)))
 318           (declare (type function fun))
 319           (lambda (new-value class object slotd)
 320             (declare (ignore class slotd))
 321             (funcall fun new-value object))))
 322        (boundp
 323         (let ((fun (slot-definition-boundp-function slotd)))
 324           (declare (type function fun))
 325           (lambda (class object slotd)
 326             (declare (ignore class slotd))
 327             (funcall fun object))))))
 328     (t
 329      (let* ((fsc-p (cond ((standard-class-p class) nil)
 330                          ((funcallable-standard-class-p class) t)
 331                          (t (error "~S is not a standard-class" class))))
 332             (function
 333              (ecase name
 334                (reader
 335                 #'make-optimized-std-slot-value-using-class-method-function)
 336                (writer
 337                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 338                (boundp
 339                 #'make-optimized-std-slot-boundp-using-class-method-function))))
 340        (declare (type function function))
 341        (values (funcall function fsc-p slotd)
 342                (slot-definition-location slotd))))))
 343
 344 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 345   (declare #.*optimize-speed*)
 346   (let ((location (slot-definition-location slotd))
 347         (slot-name (slot-definition-name slotd)))
 348     (etypecase location
 349       (fixnum (if fsc-p
 350                   (lambda (class instance slotd)
 351                     (declare (ignore slotd))
 352                     (check-obsolete-instance instance)
 353                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 354                                                  location)))
 355                       (if (eq value +slot-unbound+)
 356                           (values (slot-unbound class instance slot-name))
 357                           value)))
 358                   (lambda (class instance slotd)
 359                     (declare (ignore slotd))
 360                     (check-obsolete-instance instance)
 361                     (let ((value (clos-slots-ref (std-instance-slots instance)
 362                                                  location)))
 363                       (if (eq value +slot-unbound+)
 364                           (values (slot-unbound class instance slot-name))
 365                           value)))))
 366       (cons (lambda (class instance slotd)
 367               (declare (ignore slotd))
 368               (check-obsolete-instance instance)
 369               (let ((value (cdr location)))
 370                 (if (eq value +slot-unbound+)
 371                     (values (slot-unbound class instance slot-name))
 372                     value))))
 373       (null
 374        (lambda (class instance slotd)
 375          (declare (ignore class instance))
 376          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 377
 378 (defun make-optimized-std-setf-slot-value-using-class-method-function
 379     (fsc-p slotd)
 380   (declare #.*optimize-speed*)
 381   (let ((location (slot-definition-location slotd))
 382         (type-check-function
 383          (when (and slotd
 384                     (slot-definition-class slotd)
 385                     (safe-p (slot-definition-class slotd)))
 386            (slot-definition-type-check-function slotd))))
 387     (macrolet ((make-mf-lambda (&body body)
 388                  `(lambda (nv class instance slotd)
 389                     (declare (ignore class slotd))
 390                     (check-obsolete-instance instance)
 391                     ,@body))
 392                (make-mf-lambdas (&body body)
 393                  ;; Having separate lambdas for the NULL / not-NULL cases of
 394                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
 395                  ;; for CLOS typechecking when it's not in use.
 396                  `(if type-check-function
 397                       (make-mf-lambda
 398                        (funcall (the function type-check-function) nv)
 399                        ,@body)
 400                       (make-mf-lambda
 401                        ,@body))))
 402       (etypecase location
 403         (fixnum
 404          (if fsc-p
 405              (make-mf-lambdas
 406               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 407                     nv))
 408              (make-mf-lambdas
 409               (setf (clos-slots-ref (std-instance-slots instance) location)
 410                     nv))))
 411         (cons
 412          (make-mf-lambdas (setf (cdr location) nv)))
 413         (null (lambda (nv class instance slotd)
 414                 (declare (ignore nv class instance))
 415                 (instance-structure-protocol-error
 416                  slotd '(setf slot-value-using-class))))))))
 417
 418 (defun make-optimized-std-slot-boundp-using-class-method-function
 419     (fsc-p slotd)
 420   (declare #.*optimize-speed*)
 421   (let ((location (slot-definition-location slotd)))
 422     (etypecase location
 423       (fixnum
 424        (if fsc-p
 425            (lambda (class instance slotd)
 426              (declare (ignore class slotd))
 427              (check-obsolete-instance instance)
 428              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
 429                       +slot-unbound+)))
 430            (lambda (class instance slotd)
 431              (declare (ignore class slotd))
 432              (check-obsolete-instance instance)
 433              (not (eq (clos-slots-ref (std-instance-slots instance) location)
 434                       +slot-unbound+)))))
 435       (cons (lambda (class instance slotd)
 436               (declare (ignore class slotd))
 437               (check-obsolete-instance instance)
 438               (not (eq (cdr location) +slot-unbound+))))
 439       (null
 440        (lambda (class instance slotd)
 441          (declare (ignore class instance))
 442          (instance-structure-protocol-error slotd
 443                                             'slot-boundp-using-class))))))
 444
 445 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 446   (macrolet ((emf-funcall (emf &rest args)
 447                `(invoke-effective-method-function ,emf nil
 448                                                   :required-args ,args)))
 449     (set-fun-name
 450      (case name
 451        (reader (lambda (instance)
 452                  (emf-funcall sdfun class instance slotd)))
 453        (writer (lambda (nv instance)
 454                  (emf-funcall sdfun nv class instance slotd)))
 455        (boundp (lambda (instance)
 456                  (emf-funcall sdfun class instance slotd))))
 457      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 458 \f
 459 (defun make-std-reader-method-function (class-or-name slot-name)
 460   (declare (ignore class-or-name))
 461   (let* ((initargs (copy-tree
 462                     (make-method-function
 463                      (lambda (instance)
 464                        (pv-binding1 ((bug "Please report this")
 465                                      (instance) (instance-slots))
 466                          (instance-read-internal
 467                           .pv. instance-slots 0
 468                           (slot-value instance slot-name))))))))
 469     (setf (getf (getf initargs 'plist) :slot-name-lists)
 470           (list (list nil slot-name)))
 471     initargs))
 472
 473 (defun make-std-writer-method-function (class-or-name slot-name)
 474   (let* ((class (when (eq *boot-state* 'complete)
 475                   (if (typep class-or-name 'class)
 476                       class-or-name
 477                       (find-class class-or-name nil))))
 478          (safe-p (and class
 479                       (safe-p class)))
 480          (check-fun (lambda (new-value instance)
 481                       (let* ((class (class-of instance))
 482                              (slotd (find-slot-definition class slot-name))
 483                              (type-check-function
 484                               (when slotd
 485                                 (slot-definition-type-check-function slotd))))
 486                         (when type-check-function
 487                           (funcall type-check-function new-value)))))
 488          (initargs (copy-tree
 489                     (if safe-p
 490                         (make-method-function
 491                          (lambda (nv instance)
 492                            (funcall check-fun nv instance)
 493                            (pv-binding1 ((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 ((bug "Please report this")
 501                                          (instance) (instance-slots))
 502                              (instance-write-internal
 503                               .pv. instance-slots 0 nv
 504                               (setf (slot-value instance slot-name) nv)))))))))
 505     (setf (getf (getf initargs 'plist) :slot-name-lists)
 506           (list nil (list nil slot-name)))
 507     initargs))
 508
 509 (defun make-std-boundp-method-function (class-or-name slot-name)
 510   (declare (ignore class-or-name))
 511   (let* ((initargs (copy-tree
 512                     (make-method-function
 513                      (lambda (instance)
 514                        (pv-binding1 ((bug "Please report this")
 515                                      (instance) (instance-slots))
 516                           (instance-boundp-internal
 517                            .pv. instance-slots 0
 518                            (slot-boundp instance slot-name))))))))
 519     (setf (getf (getf initargs 'plist) :slot-name-lists)
 520           (list (list nil slot-name)))
 521     initargs))
 522 \f
 523 ;;;; FINDING SLOT DEFINITIONS
 524 ;;;
 525 ;;; Historical PCL found slot definitions by iterating over
 526 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
 527 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
 528 ;;; list up to the desired one.
 529 ;;;
 530 ;;; Current SBCL hashes the effective slot definitions, and some
 531 ;;; information pulled out from them into a simple-vector, with bucket
 532 ;;; chains made out of plists keyed by the slot names. This fixes
 533 ;;; gives O(1) performance, and avoid the GF calls.
 534 ;;;
 535 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
 536 ;;; effective slot definitions and the class they pertain to, and
 537 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 538 ;;;
 539 ;;; The only bit of cleverness in the implementation is to make the
 540 ;;; vectors fairly tight, but always longer then 0 elements:
 541 ;;;
 542 ;;; -- We don't want to waste huge amounts of space no these vectors,
 543 ;;;    which are mostly required by things like SLOT-VALUE with a
 544 ;;;    variable slot name, so a constant extension over the minimum
 545 ;;;    size seems like a good choise.
 546 ;;;
 547 ;;; -- As long as the vector always has a length > 0
 548 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
 549 ;;;    empty vector separately: it just returns a NIL.
 550 ;;;
 551 ;;; In addition to the slot-definition we also store the slot-location
 552 ;;; and type-check function for instances of standard metaclasses, so
 553 ;;; that SLOT-VALUE &co using variable slot names can get at them
 554 ;;; without additional GF calls.
 555 ;;;
 556 ;;; Notes:
 557 ;;;   It would be probably better to store the vector in wrapper
 558 ;;;   instead: one less memory indirection, one less CLOS slot
 559 ;;;   access to get at it.
 560 ;;;
 561 ;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
 562 ;;;   generic instead of checking versus STANDARD-CLASS and
 563 ;;;   FUNCALLABLE-STANDARD-CLASS.
 564
 565 (defun find-slot-definition (class slot-name)
 566   (dolist (slotd (class-slots class))
 567     (when (eq slot-name (slot-definition-name slotd))
 568       (return slotd))))
 569
 570 (defun find-slot-cell (wrapper slot-name)
 571   (declare (symbol slot-name))
 572   (let* ((vector (layout-slot-table wrapper))
 573          (index (rem (sxhash slot-name) (length vector))))
 574     (declare (simple-vector vector) (index index)
 575              (optimize (sb-c::insert-array-bounds-checks 0)))
 576     (do ((plist (the list (svref vector index)) (cdr plist)))
 577         ((not (consp plist)))
 578       (let ((key (car plist)))
 579         (setf plist (cdr plist))
 580         (when (eq key slot-name)
 581           (return (car plist)))))))
 582
 583 (defun make-slot-table (class slots &optional bootstrap)
 584   (let* ((n (+ (length slots) 2))
 585          (vector (make-array n :initial-element nil))
 586          (save-slot-location-p
 587           (or bootstrap
 588               (when (eq 'complete *boot-state*)
 589                 (let ((metaclass (class-of class)))
 590                   (or (eq metaclass *the-class-standard-class*)
 591                       (eq metaclass *the-class-funcallable-standard-class*))))))
 592          (save-type-check-function-p
 593           (unless bootstrap
 594             (and (eq 'complete *boot-state*) (safe-p class)))))
 595     (flet ((add-to-vector (name slot)
 596              (declare (symbol name)
 597                       (optimize (sb-c::insert-array-bounds-checks 0)))
 598              (let ((index (rem (sxhash name) n)))
 599                (setf (svref vector index)
 600                      (list* name (list* (when save-slot-location-p
 601                                           (if bootstrap
 602                                               (early-slot-definition-location slot)
 603                                               (slot-definition-location slot)))
 604                                         (when save-type-check-function-p
 605                                           (slot-definition-type-check-function slot))
 606                                         slot)
 607                             (svref vector index))))))
 608       (if (eq 'complete *boot-state*)
 609          (dolist (slot slots)
 610            (add-to-vector (slot-definition-name slot) slot))
 611          (dolist (slot slots)
 612            (add-to-vector (early-slot-definition-name slot) slot))))
 613     vector))