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