src/pcl/slots-boot.lisp

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