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                  (funcall #',reader-name ,object)))))
  68
  69 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  70   (aver (constantp slot-name env))
  71   (setq object (macroexpand object env))
  72   (let* ((slot-name (constant-form-value slot-name env))
  73          (bind-object (unless (or (constantp new-value env) (atom new-value))
  74                         (let* ((object-var (gensym))
  75                                (bind `((,object-var ,object))))
  76                           (setf object object-var)
  77                           bind)))
  78          (writer-name (slot-writer-name slot-name))
  79          (form
  80           `(let ((.ignore.
  81                   (load-time-value
  82                    (ensure-accessor 'writer ',writer-name ',slot-name)))
  83                  (.new-value. ,new-value))
  84             (declare (ignore .ignore.))
  85             (funcall #',writer-name .new-value. ,object)
  86             .new-value.)))
  87     (if bind-object
  88         `(let ,bind-object ,form)
  89         form)))
  90
  91 (defmacro accessor-slot-boundp (object slot-name &environment env)
  92   (aver (constantp slot-name env))
  93   (let* ((slot-name (constant-form-value slot-name env))
  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))))
  99
 100 (defun make-structure-slot-boundp-function (slotd)
 101   (declare (ignore slotd))
 102   (lambda (object)
 103     (declare (ignore object))
 104     t))
 105
 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))
 110   (:report
 111    (lambda (c s)
 112      (format s "~@<The slot ~S has neither ~S nor ~S ~
 113                 allocation, so it can't be ~A by the default ~
 114                 ~S method.~@:>"
 115              (instance-structure-protocol-error-slotd c)
 116              :instance :class
 117              (cond
 118                ((member (instance-structure-protocol-error-fun c)
 119                         '(slot-value-using-class slot-boundp-using-class))
 120                 "read")
 121                (t "written"))
 122              (instance-structure-protocol-error-fun c)))))
 123
 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)))))
 129
 130 (defun get-optimized-std-accessor-method-function (class slotd name)
 131   (cond
 132     ((structure-class-p class)
 133      (ecase name
 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)
 138      (ecase name
 139        (reader (slot-definition-reader-function slotd))
 140        (writer (slot-definition-writer-function slotd))
 141        (boundp (slot-definition-boundp-function slotd))))
 142     (t
 143      (let* ((fsc-p (cond ((standard-class-p class) nil)
 144                          ((funcallable-standard-class-p class) t)
 145                          ((std-class-p class)
 146                           ;; Shouldn't be using the optimized-std-accessors
 147                           ;; in this case.
 148                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 149                                         name slotd class)
 150                           nil)
 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,
 161             ;; 2004-07-12
 162             (value (funcall function fsc-p slotd slot-name location)))
 163        (declare (type function function))
 164        (values value (slot-definition-location slotd))))))
 165
 166 (defun make-optimized-std-reader-method-function
 167     (fsc-p slotd slot-name location)
 168   (declare #.*optimize-speed*)
 169   (set-fun-name
 170    (etypecase location
 171      (fixnum
 172       (if fsc-p
 173           (lambda (instance)
 174             (check-obsolete-instance instance)
 175             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 176                                          location)))
 177               (if (eq value +slot-unbound+)
 178                   (values
 179                    (slot-unbound (class-of instance) instance slot-name))
 180                   value)))
 181           (lambda (instance)
 182             (check-obsolete-instance instance)
 183             (let ((value (clos-slots-ref (std-instance-slots instance)
 184                                          location)))
 185               (if (eq value +slot-unbound+)
 186                   (values
 187                    (slot-unbound (class-of instance) instance slot-name))
 188                   value)))))
 189      (cons
 190       (lambda (instance)
 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))
 195               value))))
 196      (null
 197       (lambda (instance)
 198         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 199    `(reader ,slot-name)))
 200
 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
 208                        (fixnum (if fsc-p
 209                                    (lambda (nv instance)
 210                                      (check-obsolete-instance instance)
 211                                      (setf (clos-slots-ref (fsc-instance-slots instance)
 212                                                            location)
 213                                            nv))
 214                                    (lambda (nv instance)
 215                                      (check-obsolete-instance instance)
 216                                      (setf (clos-slots-ref (std-instance-slots instance)
 217                                                            location)
 218                                            nv))))
 219                        (cons (lambda (nv instance)
 220                                (check-obsolete-instance instance)
 221                                (setf (cdr location) nv)))
 222                        (null
 223                         (lambda (nv instance)
 224                           (declare (ignore nv instance))
 225                           (instance-structure-protocol-error
 226                            slotd
 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))
 241                                 (type-check-function
 242                                  (when slotd
 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
 249                       checking-fun
 250                       writer-fun)
 251                   `(writer ,slot-name))))
 252
 253 (defun make-optimized-std-boundp-method-function
 254     (fsc-p slotd slot-name location)
 255   (declare #.*optimize-speed*)
 256   (set-fun-name
 257    (etypecase location
 258      (fixnum (if fsc-p
 259                  (lambda (instance)
 260                    (check-obsolete-instance instance)
 261                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 262                                             location)
 263                             +slot-unbound+)))
 264                  (lambda (instance)
 265                    (check-obsolete-instance instance)
 266                    (not (eq (clos-slots-ref (std-instance-slots instance)
 267                                             location)
 268                             +slot-unbound+)))))
 269      (cons (lambda (instance)
 270              (check-obsolete-instance instance)
 271              (not (eq (cdr location) +slot-unbound+))))
 272      (null
 273       (lambda (instance)
 274         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 275    `(boundp ,slot-name)))
 276
 277 (defun make-optimized-structure-slot-value-using-class-method-function
 278     (function)
 279   (declare (type function function))
 280   (lambda (class object slotd)
 281     (declare (ignore class slotd))
 282     (funcall function object)))
 283
 284 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 285     (function)
 286   (declare (type function function))
 287   (lambda (nv class object slotd)
 288     (declare (ignore class slotd))
 289     (funcall function nv object)))
 290
 291 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 292   (lambda (class object slotd)
 293     (declare (ignore class object slotd))
 294     t))
 295
 296 (defun get-optimized-std-slot-value-using-class-method-function
 297     (class slotd name)
 298   (cond
 299     ((structure-class-p class)
 300      (ecase name
 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)
 307      (ecase name
 308        (reader
 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))))
 314        (writer
 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))))
 320        (boundp
 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))))))
 326     (t
 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))))
 330             (function
 331              (ecase name
 332                (reader
 333                 #'make-optimized-std-slot-value-using-class-method-function)
 334                (writer
 335                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 336                (boundp
 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))))))
 341
 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)))
 346     (etypecase location
 347       (fixnum (if fsc-p
 348                   (lambda (class instance slotd)
 349                     (declare (ignore slotd))
 350                     (check-obsolete-instance instance)
 351                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 352                                                  location)))
 353                       (if (eq value +slot-unbound+)
 354                           (values (slot-unbound class instance slot-name))
 355                           value)))
 356                   (lambda (class instance slotd)
 357                     (declare (ignore slotd))
 358                     (check-obsolete-instance instance)
 359                     (let ((value (clos-slots-ref (std-instance-slots instance)
 360                                                  location)))
 361                       (if (eq value +slot-unbound+)
 362                           (values (slot-unbound class instance slot-name))
 363                           value)))))
 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))
 370                     value))))
 371       (null
 372        (lambda (class instance slotd)
 373          (declare (ignore class instance))
 374          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 375
 376 (defun make-optimized-std-setf-slot-value-using-class-method-function
 377     (fsc-p slotd)
 378   (declare #.*optimize-speed*)
 379   (let ((location (slot-definition-location slotd))
 380         (type-check-function
 381          (when (and 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)
 389                     ,@body))
 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
 395                       (make-mf-lambda
 396                        (funcall (the function type-check-function) nv)
 397                        ,@body)
 398                       (make-mf-lambda
 399                        ,@body))))
 400       (etypecase location
 401         (fixnum
 402          (if fsc-p
 403              (make-mf-lambdas
 404               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 405                     nv))
 406              (make-mf-lambdas
 407               (setf (clos-slots-ref (std-instance-slots instance) location)
 408                     nv))))
 409         (cons
 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))))))))
 415
 416 (defun make-optimized-std-slot-boundp-using-class-method-function
 417     (fsc-p slotd)
 418   (declare #.*optimize-speed*)
 419   (let ((location (slot-definition-location slotd)))
 420     (etypecase location
 421       (fixnum
 422        (if fsc-p
 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)
 427                       +slot-unbound+)))
 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)
 432                       +slot-unbound+)))))
 433       (cons (lambda (class instance slotd)
 434               (declare (ignore class slotd))
 435               (check-obsolete-instance instance)
 436               (not (eq (cdr location) +slot-unbound+))))
 437       (null
 438        (lambda (class instance slotd)
 439          (declare (ignore class instance))
 440          (instance-structure-protocol-error slotd
 441                                             'slot-boundp-using-class))))))
 442
 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)))
 447     (set-fun-name
 448      (case name
 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)))))
 456 \f
 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
 461                      (lambda (instance)
 462                        (pv-binding1 ((bug "Please report this")
 463                                      (instance) (instance-slots))
 464                          (instance-read-internal
 465                           .pv. instance-slots 0
 466                           (slot-value instance slot-name))))))))
 467     (setf (getf (getf initargs 'plist) :slot-name-lists)
 468           (list (list nil slot-name)))
 469     initargs))
 470
 471 (defun make-std-writer-method-function (class-or-name slot-name)
 472   (let* ((class (when (eq *boot-state* 'complete)
 473                   (if (typep class-or-name 'class)
 474                       class-or-name
 475                       (find-class class-or-name nil))))
 476          (safe-p (and class
 477                       (safe-p class)))
 478          (check-fun (lambda (new-value instance)
 479                       (let* ((class (class-of instance))
 480                              (slotd (find-slot-definition class slot-name))
 481                              (type-check-function
 482                               (when slotd
 483                                 (slot-definition-type-check-function slotd))))
 484                         (when type-check-function
 485                           (funcall type-check-function new-value)))))
 486          (initargs (copy-tree
 487                     (if safe-p
 488                         (make-method-function
 489                          (lambda (nv instance)
 490                            (funcall check-fun nv instance)
 491                            (pv-binding1 ((bug "Please report this")
 492                                          (instance) (instance-slots))
 493                              (instance-write-internal
 494                               .pv. instance-slots 0 nv
 495                               (setf (slot-value instance slot-name) nv)))))
 496                         (make-method-function
 497                          (lambda (nv instance)
 498                            (pv-binding1 ((bug "Please report this")
 499                                          (instance) (instance-slots))
 500                              (instance-write-internal
 501                               .pv. instance-slots 0 nv
 502                               (setf (slot-value instance slot-name) nv)))))))))
 503     (setf (getf (getf initargs 'plist) :slot-name-lists)
 504           (list nil (list nil slot-name)))
 505     initargs))
 506
 507 (defun make-std-boundp-method-function (class-or-name slot-name)
 508   (declare (ignore class-or-name))
 509   (let* ((initargs (copy-tree
 510                     (make-method-function
 511                      (lambda (instance)
 512                        (pv-binding1 ((bug "Please report this")
 513                                      (instance) (instance-slots))
 514                           (instance-boundp-internal
 515                            .pv. instance-slots 0
 516                            (slot-boundp instance slot-name))))))))
 517     (setf (getf (getf initargs 'plist) :slot-name-lists)
 518           (list (list nil slot-name)))
 519     initargs))
 520 \f
 521 ;;;; FINDING SLOT DEFINITIONS
 522 ;;;
 523 ;;; Historical PCL found slot definitions by iterating over
 524 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
 525 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
 526 ;;; list up to the desired one.
 527 ;;;
 528 ;;; Current SBCL hashes the effective slot definitions, and some
 529 ;;; information pulled out from them into a simple-vector, with bucket
 530 ;;; chains made out of plists keyed by the slot names. This fixes
 531 ;;; gives O(1) performance, and avoid the GF calls.
 532 ;;;
 533 ;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of
 534 ;;; effective slot definitions and the class they pertain to, and
 535 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 536 ;;;
 537 ;;; The only bit of cleverness in the implementation is to make the
 538 ;;; vectors fairly tight, but always longer then 0 elements:
 539 ;;;
 540 ;;; -- We don't want to waste huge amounts of space no these vectors,
 541 ;;;    which are mostly required by things like SLOT-VALUE with a
 542 ;;;    variable slot name, so a constant extension over the minimum
 543 ;;;    size seems like a good choise.
 544 ;;;
 545 ;;; -- As long as the vector always has a length > 0
 546 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
 547 ;;;    empty vector separately: it just returns a NIL.
 548 ;;;
 549 ;;; In addition to the slot-definition we also store the slot-location
 550 ;;; and type-check function for instances of standard metaclasses, so
 551 ;;; that SLOT-VALUE &co using variable slot names can get at them
 552 ;;; without additional GF calls.
 553 ;;;
 554 ;;; Notes:
 555 ;;;   It would be probably better to store the vector in wrapper
 556 ;;;   instead: one less memory indirection, one less CLOS slot
 557 ;;;   access to get at it.
 558 ;;;
 559 ;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
 560 ;;;   generic instead of checking versus STANDARD-CLASS and
 561 ;;;   FUNCALLABLE-STANDARD-CLASS.
 562
 563 (defun find-slot-definition (class slot-name)
 564   (dolist (slotd (class-slots class))
 565     (when (eq slot-name (slot-definition-name slotd))
 566       (return slotd))))
 567
 568 (defun find-slot-cell (wrapper slot-name)
 569   (declare (symbol slot-name))
 570   (let* ((vector (layout-slot-table wrapper))
 571          (index (rem (sxhash slot-name) (length vector))))
 572     (declare (simple-vector vector) (index index)
 573              (optimize (sb-c::insert-array-bounds-checks 0)))
 574     (do ((plist (the list (svref vector index)) (cdr plist)))
 575         ((not (consp plist)))
 576       (let ((key (car plist)))
 577         (setf plist (cdr plist))
 578         (when (eq key slot-name)
 579           (return (car plist)))))))
 580
 581 (defun make-slot-table (class slots)
 582   (let* ((n (+ (length slots) 2))
 583          (vector (make-array n :initial-element nil))
 584          (save-slot-location-p
 585           (when (eq 'complete *boot-state*)
 586             (let ((metaclass (class-of class)))
 587               (or (eq metaclass *the-class-standard-class*)
 588                   (eq metaclass *the-class-funcallable-standard-class*)))))
 589          (save-type-check-function-p (and save-slot-location-p (safe-p class))))
 590     (flet ((add-to-vector (name slot)
 591              (declare (symbol name)
 592                       (optimize (sb-c::insert-array-bounds-checks 0)))
 593              (let ((index (rem (sxhash name) n)))
 594                (setf (svref vector index)
 595                      (list* name (list* (if save-slot-location-p
 596                                             (slot-definition-location slot)
 597                                             ;; T tells SLOT-VALUE & SET-SLOT-VALUE
 598                                             ;; that this is a non-standard class.
 599                                             t)
 600                                         (when save-type-check-function-p
 601                                           (slot-definition-type-check-function slot))
 602                                         slot)
 603                             (svref vector index))))))
 604       (if (eq 'complete *boot-state*)
 605          (dolist (slot slots)
 606            (add-to-vector (slot-definition-name slot) slot))
 607          (dolist (slot slots)
 608            (add-to-vector (early-slot-definition-name slot) slot))))
 609     vector))