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 quiet-funcall (fun &rest args)
  60   ;; Don't give a style-warning about undefined function here.
  61   `(funcall (locally (declare (muffle-conditions style-warning))
  62               ,fun)
  63             ,@args))
  64
  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)))))
  74
  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)
  83                           bind)))
  84          (writer-name (slot-writer-name slot-name))
  85          (form
  86           `(let ((.ignore.
  87                   (load-time-value
  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)
  92             .new-value.)))
  93     (if bind-object
  94         `(let ,bind-object ,form)
  95         form)))
  96
  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))))
 105
 106 (defun make-structure-slot-boundp-function (slotd)
 107   (declare (ignore slotd))
 108   (lambda (object)
 109     (declare (ignore object))
 110     t))
 111
 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))
 116   (:report
 117    (lambda (c s)
 118      (format s "~@<The slot ~S has neither ~S nor ~S ~
 119                 allocation, so it can't be ~A by the default ~
 120                 ~S method.~@:>"
 121              (instance-structure-protocol-error-slotd c)
 122              :instance :class
 123              (cond
 124                ((member (instance-structure-protocol-error-fun c)
 125                         '(slot-value-using-class slot-boundp-using-class))
 126                 "read")
 127                (t "written"))
 128              (instance-structure-protocol-error-fun c)))))
 129
 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)))))
 135
 136 (defun get-optimized-std-accessor-method-function (class slotd name)
 137   (cond
 138     ((structure-class-p class)
 139      (ecase name
 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)
 144      (ecase name
 145        (reader (slot-definition-reader-function slotd))
 146        (writer (slot-definition-writer-function slotd))
 147        (boundp (slot-definition-boundp-function slotd))))
 148     (t
 149      (let* ((fsc-p (cond ((standard-class-p class) nil)
 150                          ((funcallable-standard-class-p class) t)
 151                          ((std-class-p class)
 152                           ;; Shouldn't be using the optimized-std-accessors
 153                           ;; in this case.
 154                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 155                                         name slotd class)
 156                           nil)
 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,
 167             ;; 2004-07-12
 168             (value (funcall function fsc-p slotd slot-name location)))
 169        (declare (type function function))
 170        (values value (slot-definition-location slotd))))))
 171
 172 (defun make-optimized-std-reader-method-function
 173     (fsc-p slotd slot-name location)
 174   (declare #.*optimize-speed*)
 175   (set-fun-name
 176    (etypecase location
 177      (fixnum
 178       (if fsc-p
 179           (lambda (instance)
 180             (check-obsolete-instance instance)
 181             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 182                                          location)))
 183               (if (eq value +slot-unbound+)
 184                   (values
 185                    (slot-unbound (class-of instance) instance slot-name))
 186                   value)))
 187           (lambda (instance)
 188             (check-obsolete-instance instance)
 189             (let ((value (clos-slots-ref (std-instance-slots instance)
 190                                          location)))
 191               (if (eq value +slot-unbound+)
 192                   (values
 193                    (slot-unbound (class-of instance) instance slot-name))
 194                   value)))))
 195      (cons
 196       (lambda (instance)
 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))
 201               value))))
 202      (null
 203       (lambda (instance)
 204         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 205    `(reader ,slot-name)))
 206
 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
 214                        (fixnum
 215                         (if fsc-p
 216                             (lambda (nv instance)
 217                               (check-obsolete-instance instance)
 218                               (setf (clos-slots-ref (fsc-instance-slots instance)
 219                                                     location)
 220                                     nv))
 221                             (lambda (nv instance)
 222                               (check-obsolete-instance instance)
 223                               (setf (clos-slots-ref (std-instance-slots instance)
 224                                                     location)
 225                                     nv))))
 226                        (cons
 227                         (lambda (nv instance)
 228                           (check-obsolete-instance instance)
 229                           (setf (cdr location) nv)))
 230                        (null
 231                         (lambda (nv instance)
 232                           (declare (ignore nv instance))
 233                           (instance-structure-protocol-error
 234                            slotd
 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))
 246                                 (type-check-function
 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
 254                       checking-fun
 255                       writer-fun)
 256                   `(writer ,slot-name))))
 257
 258 (defun make-optimized-std-boundp-method-function
 259     (fsc-p slotd slot-name location)
 260   (declare #.*optimize-speed*)
 261   (set-fun-name
 262    (etypecase location
 263      (fixnum (if fsc-p
 264                  (lambda (instance)
 265                    (check-obsolete-instance instance)
 266                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 267                                             location)
 268                             +slot-unbound+)))
 269                  (lambda (instance)
 270                    (check-obsolete-instance instance)
 271                    (not (eq (clos-slots-ref (std-instance-slots instance)
 272                                             location)
 273                             +slot-unbound+)))))
 274      (cons (lambda (instance)
 275              (check-obsolete-instance instance)
 276              (not (eq (cdr location) +slot-unbound+))))
 277      (null
 278       (lambda (instance)
 279         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 280    `(boundp ,slot-name)))
 281
 282 (defun make-optimized-structure-slot-value-using-class-method-function
 283     (function)
 284   (declare (type function function))
 285   (lambda (class object slotd)
 286     (declare (ignore class slotd))
 287     (funcall function object)))
 288
 289 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 290     (function)
 291   (declare (type function function))
 292   (lambda (nv class object slotd)
 293     (declare (ignore class slotd))
 294     (funcall function nv object)))
 295
 296 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 297   (lambda (class object slotd)
 298     (declare (ignore class object slotd))
 299     t))
 300
 301 (defun get-optimized-std-slot-value-using-class-method-function
 302     (class slotd name)
 303   (cond
 304     ((structure-class-p class)
 305      (ecase name
 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)
 312      (ecase name
 313        (reader
 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))))
 319        (writer
 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))))
 325        (boundp
 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))))))
 331     (t
 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))))
 335             (function
 336              (ecase name
 337                (reader
 338                 #'make-optimized-std-slot-value-using-class-method-function)
 339                (writer
 340                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 341                (boundp
 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))))))
 346
 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)))
 351     (etypecase location
 352       (fixnum (if fsc-p
 353                   (lambda (class instance slotd)
 354                     (declare (ignore slotd))
 355                     (check-obsolete-instance instance)
 356                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 357                                                  location)))
 358                       (if (eq value +slot-unbound+)
 359                           (values (slot-unbound class instance slot-name))
 360                           value)))
 361                   (lambda (class instance slotd)
 362                     (declare (ignore slotd))
 363                     (check-obsolete-instance instance)
 364                     (let ((value (clos-slots-ref (std-instance-slots instance)
 365                                                  location)))
 366                       (if (eq value +slot-unbound+)
 367                           (values (slot-unbound class instance slot-name))
 368                           value)))))
 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))
 375                     value))))
 376       (null
 377        (lambda (class instance slotd)
 378          (declare (ignore class instance))
 379          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 380
 381 (defun make-optimized-std-setf-slot-value-using-class-method-function
 382     (fsc-p slotd)
 383   (declare #.*optimize-speed*)
 384   (let ((location (slot-definition-location slotd))
 385         (type-check-function
 386          (when (and 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)
 394                     ,@body))
 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
 400                       (make-mf-lambda
 401                        (funcall (the function type-check-function) nv)
 402                        ,@body)
 403                       (make-mf-lambda
 404                        ,@body))))
 405       (etypecase location
 406         (fixnum
 407          (if fsc-p
 408              (make-mf-lambdas
 409               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 410                     nv))
 411              (make-mf-lambdas
 412               (setf (clos-slots-ref (std-instance-slots instance) location)
 413                     nv))))
 414         (cons
 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))))))))
 420
 421 (defun make-optimized-std-slot-boundp-using-class-method-function
 422     (fsc-p slotd)
 423   (declare #.*optimize-speed*)
 424   (let ((location (slot-definition-location slotd)))
 425     (etypecase location
 426       (fixnum
 427        (if fsc-p
 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)
 432                       +slot-unbound+)))
 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)
 437                       +slot-unbound+)))))
 438       (cons (lambda (class instance slotd)
 439               (declare (ignore class slotd))
 440               (check-obsolete-instance instance)
 441               (not (eq (cdr location) +slot-unbound+))))
 442       (null
 443        (lambda (class instance slotd)
 444          (declare (ignore class instance))
 445          (instance-structure-protocol-error slotd
 446                                             'slot-boundp-using-class))))))
 447
 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)))
 452     (set-fun-name
 453      (case name
 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)))))
 461 \f
 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
 466                      (lambda (instance)
 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)))
 474     initargs))
 475
 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)
 479                       class-or-name
 480                       (find-class class-or-name nil))))
 481          (safe-p (and class
 482                       (safe-p class)))
 483          (check-fun (lambda (new-value instance)
 484                       (let* ((class (class-of instance))
 485                              (slotd (find-slot-definition class slot-name))
 486                              (type-check-function
 487                               (when slotd
 488                                 (slot-definition-type-check-function slotd))))
 489                         (when type-check-function
 490                           (funcall type-check-function new-value)))))
 491          (initargs (copy-tree
 492                     (if safe-p
 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)))
 510     initargs))
 511
 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
 516                      (lambda (instance)
 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)))
 524     initargs))
 525 \f
 526 ;;;; FINDING SLOT DEFINITIONS
 527 ;;;
 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.
 532 ;;;
 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.
 537 ;;;
 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.
 541 ;;;
 542 ;;; The only bit of cleverness in the implementation is to make the
 543 ;;; vectors fairly tight, but always longer then 0 elements:
 544 ;;;
 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.
 549 ;;;
 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.
 553 ;;;
 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.
 558 ;;;
 559 ;;; Notes:
 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.
 563 ;;;
 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.
 567
 568 (defun find-slot-definition (class slot-name)
 569   (dolist (slotd (class-slots class))
 570     (when (eq slot-name (slot-definition-name slotd))
 571       (return slotd))))
 572
 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)))))))
 585
 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
 590           (or bootstrap
 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
 596           (unless bootstrap
 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
 604                                           (if bootstrap
 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))
 609                                         slot)
 610                             (svref vector index))))))
 611       (if (eq 'complete **boot-state**)
 612          (dolist (slot slots)
 613            (add-to-vector (slot-definition-name slot) slot))
 614          (dolist (slot slots)
 615            (add-to-vector (early-slot-definition-name slot) slot))))
 616     vector))