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 (defun make-structure-slot-boundp-function (slotd)
  60   (declare (ignore slotd))
  61   (named-lambda always-bound (object)
  62     (declare (ignore object))
  63     t))
  64
  65 (define-condition instance-structure-protocol-error
  66     (reference-condition error)
  67   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
  68    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
  69   (:report
  70    (lambda (c s)
  71      (format s "~@<The slot ~S has neither ~S nor ~S ~
  72                 allocation, so it can't be ~A by the default ~
  73                 ~S method.~@:>"
  74              (instance-structure-protocol-error-slotd c)
  75              :instance :class
  76              (cond
  77                ((member (instance-structure-protocol-error-fun c)
  78                         '(slot-value-using-class slot-boundp-using-class))
  79                 "read")
  80                (t "written"))
  81              (instance-structure-protocol-error-fun c)))))
  82
  83 (defun instance-structure-protocol-error (slotd fun)
  84   (error 'instance-structure-protocol-error
  85          :slotd slotd :fun fun
  86          :references (list `(:amop :generic-function ,fun)
  87                            '(:amop :section (5 5 3)))))
  88
  89 (defun get-optimized-std-accessor-method-function (class slotd name)
  90   (cond
  91     ((structure-class-p class)
  92      (ecase name
  93        (reader (slot-definition-internal-reader-function slotd))
  94        (writer (slot-definition-internal-writer-function slotd))
  95        (boundp (make-structure-slot-boundp-function slotd))))
  96     ((condition-class-p class)
  97      (let ((info (the slot-info (slot-definition-info slotd))))
  98        (ecase name
  99          (reader (slot-info-reader info))
 100          (writer (slot-info-writer info))
 101          (boundp (slot-info-boundp info)))))
 102     (t
 103      (let* ((fsc-p (cond ((standard-class-p class) nil)
 104                          ((funcallable-standard-class-p class) t)
 105                          ((std-class-p class)
 106                           ;; Shouldn't be using the optimized-std-accessors
 107                           ;; in this case.
 108                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 109                                         name slotd class)
 110                           nil)
 111                          (t (error "~S is not a STANDARD-CLASS." class))))
 112             (slot-name (slot-definition-name slotd))
 113             (location (slot-definition-location slotd))
 114             (function (ecase name
 115                         (reader #'make-optimized-std-reader-method-function)
 116                         (writer #'make-optimized-std-writer-method-function)
 117                         (boundp #'make-optimized-std-boundp-method-function)))
 118             ;; KLUDGE: we need this slightly hacky calling convention
 119             ;; for these functions for bootstrapping reasons: see
 120             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 121             ;; 2004-07-12
 122             (value (funcall function fsc-p slotd slot-name location)))
 123        (declare (type function function))
 124        (values value (slot-definition-location slotd))))))
 125
 126 (defun make-optimized-std-reader-method-function
 127     (fsc-p slotd slot-name location)
 128   (set-fun-name
 129    (etypecase location
 130      (fixnum
 131       (if fsc-p
 132           (lambda (instance)
 133             (check-obsolete-instance instance)
 134             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 135                                          location)))
 136               (if (eq value +slot-unbound+)
 137                   (values
 138                    (slot-unbound (class-of instance) instance slot-name))
 139                   value)))
 140           (lambda (instance)
 141             (check-obsolete-instance instance)
 142             (let ((value (clos-slots-ref (std-instance-slots instance)
 143                                          location)))
 144               (if (eq value +slot-unbound+)
 145                   (values
 146                    (slot-unbound (class-of instance) instance slot-name))
 147                   value)))))
 148      (cons
 149       (lambda (instance)
 150         (check-obsolete-instance instance)
 151         (let ((value (cdr location)))
 152           (if (eq value +slot-unbound+)
 153               (values (slot-unbound (class-of instance) instance slot-name))
 154               value))))
 155      (null
 156       (lambda (instance)
 157         (declare (ignore instance))
 158         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 159    `(reader ,slot-name)))
 160
 161 (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location)
 162   ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
 163   (let* ((class (when slotd (slot-definition-class slotd)))
 164          (safe-p (when slotd (safe-p class)))
 165          (orig-wrapper (when safe-p (class-wrapper class)))
 166          (info (when safe-p (slot-definition-info slotd)))
 167          (writer-fun (etypecase location
 168                        ;; In SAFE-P case the typechecking already validated the instance.
 169                        (fixnum
 170                         (if fsc-p
 171                             (if safe-p
 172                                 (lambda (nv instance)
 173                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 174                                                         location)
 175                                         nv))
 176                                 (lambda (nv instance)
 177                                   (check-obsolete-instance instance)
 178                                   (setf (clos-slots-ref (fsc-instance-slots instance)
 179                                                         location)
 180                                         nv)))
 181                             (if safe-p
 182                                 (lambda (nv instance)
 183                                   (setf (clos-slots-ref (std-instance-slots instance)
 184                                                         location)
 185                                         nv))
 186                                 (lambda (nv instance)
 187                                   (check-obsolete-instance instance)
 188                                   (setf (clos-slots-ref (std-instance-slots instance)
 189                                                         location)
 190                                         nv)))))
 191                        (cons
 192                         (if safe-p
 193                             (lambda (nv instance)
 194                               (declare (ignore instance))
 195                               (setf (cdr location) nv))
 196                             (lambda (nv instance)
 197                               (check-obsolete-instance instance)
 198                               (setf (cdr location) nv))))
 199                        (null
 200                         (lambda (nv instance)
 201                           (declare (ignore nv instance))
 202                           (instance-structure-protocol-error
 203                            slotd
 204                            '(setf slot-value-using-class))))))
 205          (checking-fun (when safe-p
 206                          (lambda (new-value instance)
 207                            ;; If we have a TYPE-CHECK-FUNCTION, call it.
 208                            (let* (;; Note that the class of INSTANCE here is not
 209                                   ;; neccessarily the SLOT-DEFINITION-CLASS of
 210                                   ;; the SLOTD passed to M-O-S-W-M-F, since it's
 211                                   ;; e.g. possible for a subclass to define a
 212                                   ;; slot of the same name but with no
 213                                   ;; accessors. So we may need to fetch the
 214                                   ;; right SLOT-INFO from the wrapper instead of
 215                                   ;; just closing over it.
 216                                   (wrapper (valid-wrapper-of instance))
 217                                   (typecheck
 218                                    (slot-info-typecheck
 219                                     (if (eq wrapper orig-wrapper)
 220                                         info
 221                                         (cdr (find-slot-cell wrapper slot-name))))))
 222                              (when typecheck
 223                                (funcall typecheck new-value)))
 224                            ;; Then call the real writer.
 225                            (funcall writer-fun new-value instance)))))
 226     (set-fun-name (if safe-p
 227                       checking-fun
 228                       writer-fun)
 229                   `(writer ,slot-name))))
 230
 231 (defun make-optimized-std-boundp-method-function
 232     (fsc-p slotd slot-name location)
 233   (set-fun-name
 234    (etypecase location
 235      (fixnum (if fsc-p
 236                  (lambda (instance)
 237                    (check-obsolete-instance instance)
 238                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 239                                             location)
 240                             +slot-unbound+)))
 241                  (lambda (instance)
 242                    (check-obsolete-instance instance)
 243                    (not (eq (clos-slots-ref (std-instance-slots instance)
 244                                             location)
 245                             +slot-unbound+)))))
 246      (cons (lambda (instance)
 247              (check-obsolete-instance instance)
 248              (not (eq (cdr location) +slot-unbound+))))
 249      (null
 250       (lambda (instance)
 251         (declare (ignore instance))
 252         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 253    `(boundp ,slot-name)))
 254
 255 (defun make-optimized-structure-slot-value-using-class-method-function
 256     (function)
 257   (declare (type function function))
 258   (lambda (class object slotd)
 259     (declare (ignore class slotd))
 260     (funcall function object)))
 261
 262 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 263     (function)
 264   (declare (type function function))
 265   (lambda (nv class object slotd)
 266     (declare (ignore class slotd))
 267     (funcall function nv object)))
 268
 269 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 270   (lambda (class object slotd)
 271     (declare (ignore class object slotd))
 272     t))
 273
 274 (defun get-optimized-std-slot-value-using-class-method-function
 275     (class slotd name)
 276   (cond
 277     ((structure-class-p class)
 278      (ecase name
 279        (reader (make-optimized-structure-slot-value-using-class-method-function
 280                 (slot-definition-internal-reader-function slotd)))
 281        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 282                 (slot-definition-internal-writer-function slotd)))
 283        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
 284     ((condition-class-p class)
 285      (let ((info (slot-definition-info slotd)))
 286        (ecase name
 287          (reader
 288           (let ((fun (slot-info-reader info)))
 289             (lambda (class object slotd)
 290               (declare (ignore class slotd))
 291               (funcall fun object))))
 292          (writer
 293           (let ((fun (slot-info-writer info)))
 294             (lambda (new-value class object slotd)
 295               (declare (ignore class slotd))
 296               (funcall fun new-value object))))
 297          (boundp
 298           (let ((fun (slot-info-boundp info)))
 299             (lambda (class object slotd)
 300               (declare (ignore class slotd))
 301               (funcall fun object)))))))
 302     (t
 303      (let* ((fsc-p (cond ((standard-class-p class) nil)
 304                          ((funcallable-standard-class-p class) t)
 305                          (t (error "~S is not a standard-class" class))))
 306             (function
 307              (ecase name
 308                (reader
 309                 #'make-optimized-std-slot-value-using-class-method-function)
 310                (writer
 311                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 312                (boundp
 313                 #'make-optimized-std-slot-boundp-using-class-method-function))))
 314        (declare (type function function))
 315        (values (funcall function fsc-p slotd)
 316                (slot-definition-location slotd))))))
 317
 318 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 319   (let ((location (slot-definition-location slotd))
 320         (slot-name (slot-definition-name slotd)))
 321     (etypecase location
 322       (fixnum (if fsc-p
 323                   (lambda (class instance slotd)
 324                     (declare (ignore slotd))
 325                     (check-obsolete-instance instance)
 326                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 327                                                  location)))
 328                       (if (eq value +slot-unbound+)
 329                           (values (slot-unbound class instance slot-name))
 330                           value)))
 331                   (lambda (class instance slotd)
 332                     (declare (ignore slotd))
 333                     (check-obsolete-instance instance)
 334                     (let ((value (clos-slots-ref (std-instance-slots instance)
 335                                                  location)))
 336                       (if (eq value +slot-unbound+)
 337                           (values (slot-unbound class instance slot-name))
 338                           value)))))
 339       (cons (lambda (class instance slotd)
 340               (declare (ignore slotd))
 341               (check-obsolete-instance instance)
 342               (let ((value (cdr location)))
 343                 (if (eq value +slot-unbound+)
 344                     (values (slot-unbound class instance slot-name))
 345                     value))))
 346       (null
 347        (lambda (class instance slotd)
 348          (declare (ignore class instance))
 349          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 350
 351 (defun make-optimized-std-setf-slot-value-using-class-method-function
 352     (fsc-p slotd)
 353   (let* ((location (slot-definition-location slotd))
 354          (class (slot-definition-class slotd))
 355          (typecheck
 356           (when (safe-p class)
 357             (slot-info-typecheck (slot-definition-info slotd)))))
 358     (macrolet ((make-mf-lambda (&body body)
 359                  `(lambda (nv class instance slotd)
 360                     (declare (ignore class slotd))
 361                     (check-obsolete-instance instance)
 362                     ,@body))
 363                (make-mf-lambdas (&body body)
 364                  ;; Having separate lambdas for the NULL / not-NULL cases of
 365                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
 366                  ;; for CLOS typechecking when it's not in use.
 367                  `(if typecheck
 368                       (make-mf-lambda
 369                        (funcall (the function typecheck) nv)
 370                        ,@body)
 371                       (make-mf-lambda
 372                        ,@body))))
 373       (etypecase location
 374         (fixnum
 375          (if fsc-p
 376              (make-mf-lambdas
 377               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 378                     nv))
 379              (make-mf-lambdas
 380               (setf (clos-slots-ref (std-instance-slots instance) location)
 381                     nv))))
 382         (cons
 383          (make-mf-lambdas (setf (cdr location) nv)))
 384         (null (lambda (nv class instance slotd)
 385                 (declare (ignore nv class instance))
 386                 (instance-structure-protocol-error
 387                  slotd '(setf slot-value-using-class))))))))
 388
 389 (defun make-optimized-std-slot-boundp-using-class-method-function
 390     (fsc-p slotd)
 391   (let ((location (slot-definition-location slotd)))
 392     (etypecase location
 393       (fixnum
 394        (if fsc-p
 395            (lambda (class instance slotd)
 396              (declare (ignore class slotd))
 397              (check-obsolete-instance instance)
 398              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
 399                       +slot-unbound+)))
 400            (lambda (class instance slotd)
 401              (declare (ignore class slotd))
 402              (check-obsolete-instance instance)
 403              (not (eq (clos-slots-ref (std-instance-slots instance) location)
 404                       +slot-unbound+)))))
 405       (cons (lambda (class instance slotd)
 406               (declare (ignore class slotd))
 407               (check-obsolete-instance instance)
 408               (not (eq (cdr location) +slot-unbound+))))
 409       (null
 410        (lambda (class instance slotd)
 411          (declare (ignore class instance))
 412          (instance-structure-protocol-error slotd
 413                                             'slot-boundp-using-class))))))
 414
 415 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 416   (macrolet ((emf-funcall (emf &rest args)
 417                `(invoke-effective-method-function ,emf nil
 418                                                   :required-args ,args)))
 419     (set-fun-name
 420      (case name
 421        (reader (lambda (instance)
 422                  (emf-funcall sdfun class instance slotd)))
 423        (writer (lambda (nv instance)
 424                  (emf-funcall sdfun nv class instance slotd)))
 425        (boundp (lambda (instance)
 426                  (emf-funcall sdfun class instance slotd))))
 427      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 428 \f
 429 (defun maybe-class (class-or-name)
 430   (when (eq **boot-state** 'complete)
 431     (if (typep class-or-name 'class)
 432         class-or-name
 433         (find-class class-or-name nil))))
 434
 435 (defun make-std-reader-method-function (class-or-name slot-name)
 436   (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t)
 437     (:standard
 438      (let* ((initargs (copy-tree
 439                        (make-method-function
 440                         (lambda (instance)
 441                           (pv-binding1 ((bug "Please report this")
 442                                         (instance) (instance-slots))
 443                             (instance-read-standard
 444                              .pv. instance-slots 0
 445                              (slot-value instance slot-name))))))))
 446        (setf (getf (getf initargs 'plist) :slot-name-lists)
 447              (list (list slot-name)))
 448        initargs))
 449     ((:custom :accessor)
 450      (let* ((initargs (copy-tree
 451                        (make-method-function
 452                         (lambda (instance)
 453                           (pv-binding1 ((bug "Please report this")
 454                                         (instance) nil)
 455                             (instance-read-custom .pv. 0 instance)))))))
 456        (setf (getf (getf initargs 'plist) :slot-name-lists)
 457              (list (list slot-name)))
 458        initargs))))
 459
 460 (defun make-std-writer-method-function (class-or-name slot-name)
 461   (let ((class (maybe-class class-or-name)))
 462     (ecase (slot-access-strategy class slot-name 'writer t)
 463       (:standard
 464        (let ((initargs (copy-tree
 465                         (if (and class (safe-p class))
 466                             (make-method-function
 467                              (lambda (nv instance)
 468                                (pv-binding1 ((bug "Please report this")
 469                                              (instance) (instance-slots))
 470                                  (instance-write-standard
 471                                   .pv. instance-slots 0 nv
 472                                   (setf (slot-value instance slot-name) .good-new-value.)
 473                                   nil t))))
 474                             (make-method-function
 475                              (lambda (nv instance)
 476                                (pv-binding1 ((bug "Please report this")
 477                                              (instance) (instance-slots))
 478                                  (instance-write-standard
 479                                   .pv. instance-slots 0 nv
 480                                   (setf (slot-value instance slot-name) .good-new-value.)))))))))
 481          (setf (getf (getf initargs 'plist) :slot-name-lists)
 482                (list nil (list slot-name)))
 483          initargs))
 484      ((:custom :accessor)
 485       (let ((initargs (copy-tree
 486                        (make-method-function
 487                         (lambda (nv instance)
 488                           (pv-binding1 ((bug "Please report this")
 489                                         (instance) nil)
 490                             (instance-write-custom .pv. 0 instance nv)))))))
 491         (setf (getf (getf initargs 'plist) :slot-name-lists)
 492               (list nil (list slot-name)))
 493         initargs)))))
 494
 495 (defun make-std-boundp-method-function (class-or-name slot-name)
 496   (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t)
 497     (:standard
 498      (let ((initargs (copy-tree
 499                       (make-method-function
 500                        (lambda (instance)
 501                          (pv-binding1 ((bug "Please report this")
 502                                        (instance) (instance-slots))
 503                            (instance-boundp-standard
 504                             .pv. instance-slots 0
 505                             (slot-boundp instance slot-name))))))))
 506        (setf (getf (getf initargs 'plist) :slot-name-lists)
 507              (list (list slot-name)))
 508        initargs))
 509     ((:custom :accessor)
 510      (let ((initargs (copy-tree
 511                       (make-method-function
 512                        (lambda (instance)
 513                          (pv-binding1 ((bug "Please report this")
 514                                        (instance) nil)
 515                            (instance-boundp-custom .pv. 0 instance)))))))
 516        (setf (getf (getf initargs 'plist) :slot-name-lists)
 517              (list (list slot-name)))
 518        initargs))))
 519 \f
 520 ;;;; FINDING SLOT DEFINITIONS
 521 ;;;
 522 ;;; Historical PCL found slot definitions by iterating over
 523 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
 524 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
 525 ;;; list up to the desired one.
 526 ;;;
 527 ;;; Current SBCL hashes the effective slot definitions, and some
 528 ;;; information pulled out from them into a simple-vector, with bucket
 529 ;;; chains made out of plists keyed by the slot names. This fixes
 530 ;;; gives O(1) performance, and avoid the GF calls.
 531 ;;;
 532 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
 533 ;;; effective slot definitions and the class they pertain to, and
 534 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 535 ;;;
 536 ;;; The only bit of cleverness in the implementation is to make the
 537 ;;; vectors fairly tight, but always longer then 0 elements:
 538 ;;;
 539 ;;; -- We don't want to waste huge amounts of space no these vectors,
 540 ;;;    which are mostly required by things like SLOT-VALUE with a
 541 ;;;    variable slot name, so a constant extension over the minimum
 542 ;;;    size seems like a good choise.
 543 ;;;
 544 ;;; -- As long as the vector always has a length > 0
 545 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
 546 ;;;    empty vector separately: it just returns a NIL.
 547 ;;;
 548 ;;; In addition to the slot-definition we also store the slot-location
 549 ;;; and type-check function for instances of standard metaclasses, so
 550 ;;; that SLOT-VALUE &co using variable slot names can get at them
 551 ;;; without additional GF calls.
 552 ;;;
 553 ;;; Notes:
 554 ;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
 555 ;;;   generic instead of checking versus STANDARD-CLASS and
 556 ;;;   FUNCALLABLE-STANDARD-CLASS.
 557 ;;;
 558 ;;;   Uh, the comments above talking about how FIND-SLOT-DEFINITION
 559 ;;;   does something with slot vectors has no basis in reality.
 560 ;;;   Probably the comments need fixing, rather than the code.
 561
 562 (defun find-slot-definition (class slot-name &optional errorp)
 563   (unless (class-finalized-p class)
 564     (or (try-finalize-inheritance class)
 565         (if errorp
 566             (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
 567                    slot-name class)
 568             (return-from find-slot-definition (values nil nil)))))
 569   (dolist (slotd (class-slots class)
 570            (if errorp
 571                (error "No slot called ~S in ~S." slot-name class)
 572                (values nil t)))
 573     (when (eq slot-name (slot-definition-name slotd))
 574       (return (values slotd t)))))
 575
 576 (defun find-slot-cell (wrapper slot-name)
 577   (declare (symbol slot-name))
 578   (declare (optimize (sb-c::insert-array-bounds-checks 0)))
 579   (let* ((vector (layout-slot-table wrapper))
 580          (modulus (truly-the index (svref vector 0)))
 581          ;; Can elide the 'else' branch of (OR symbol-hash ensure-symbol-hash)
 582          ;; because every symbol in the slot-table already got a nonzero hash.
 583          (index (rem (symbol-hash slot-name) modulus))
 584          (probe (svref vector (1+ index))))
 585     (declare (simple-vector vector) (index index))
 586     (cond ((fixnump probe)
 587            (do* ((count (svref vector (1- (truly-the index probe))))
 588                  (end (truly-the index (+ probe count)))
 589                  (j probe (1+ j)))
 590                 ((>= j end))
 591              (declare (index count j))
 592              (when (eq (svref vector j) slot-name)
 593                (return (svref vector (truly-the index (+ j count)))))))
 594           ((eq (car (truly-the list probe)) slot-name)
 595            (cdr probe)))))
 596
 597 (defun make-slot-table (class slots &optional bootstrap)
 598   (unless slots
 599     ;; *** If changing this empty table value to something else,
 600     ;;     be sure to make a similar change to MAKE-COLD-LAYOUT in
 601     ;;     compiler/generic/genesis as well as in DEFSTRUCT LAYOUT.
 602     ;;     A DEFCONSTANT for this would only transfer the problem
 603     ;;     to cold-init in a different sort of way. :-(
 604     (return-from make-slot-table #(1 nil)))
 605   (let* ((n (+ (logior (length slots) 1) 2)) ; an odd divisor is preferred
 606          (vector (make-array n :initial-element nil)))
 607     (flet ((add-to-vector (name slot)
 608              (declare (symbol name)
 609                       (optimize (sb-c::insert-array-bounds-checks 0)))
 610              (let ((index (rem (ensure-symbol-hash name) n)))
 611                (setf (svref vector index)
 612                      (acons name
 613                             (cons (when (or bootstrap
 614                                             (and (standard-class-p class)
 615                                                  (slot-accessor-std-p slot 'all)))
 616                                     (if bootstrap
 617                                         (early-slot-definition-location slot)
 618                                         (slot-definition-location slot)))
 619                                   (the slot-info
 620                                     (if bootstrap
 621                                         (early-slot-definition-info slot)
 622                                         (slot-definition-info slot))))
 623                             (svref vector index))))))
 624       (if (eq 'complete **boot-state**)
 625           (dolist (slot slots)
 626             (add-to-vector (slot-definition-name slot) slot))
 627           (dolist (slot slots)
 628             (add-to-vector (early-slot-definition-name slot) slot))))
 629     ;; The VECTOR as computed above implements a hash table with chaining.
 630     ;; Rather than store chains using cons cells, chains can be stored in the
 631     ;; vector itself at the end, with the table entry pointing to another
 632     ;; index in the vector. The chain length is stored first, then all keys,
 633     ;; then all values. The resulting structure takes less memory than
 634     ;; linked lists, and can be scanned faster. As an exception, for lists
 635     ;; of length 1, the table cell holds a (key . value) pair directly.
 636     (let* ((final-n
 637             (+ 1 n
 638                ;; number of additional cells needed to represent linked lists
 639                ;; as length-prefixed subsequences in the final vector.
 640                (loop for cell across vector
 641                      for count = (length cell)
 642                      sum (if (<= count 1) 0 (1+ (* count 2))))))
 643            (final-vector (make-array final-n))
 644            (data-index (1+ n))) ; after the hashtable portion of the vector
 645       (setf (aref final-vector 0) n) ; the modulus
 646       (dotimes (i n final-vector)
 647         (let ((alist (aref vector i)))
 648           (if (not (cdr alist)) ; store it in the final vector as-is
 649               (setf (aref final-vector (1+ i)) (car alist))
 650               (let ((count (length alist)))
 651                 ;; Probed cell holds the index of the first symbol.
 652                 ;; The symbol count precedes the first symbol cell.
 653                 (setf (aref final-vector (1+ i)) (1+ data-index)
 654                       (aref final-vector data-index) count)
 655                 (dolist (cell alist)
 656                   (setf (aref final-vector (incf data-index)) (car cell)))
 657                 (dolist (cell alist)
 658                   (setf (aref final-vector (incf data-index)) (cdr cell)))
 659                 (incf data-index))))))))