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 (defvar *!temporary-ensure-accessor-functions* nil)
  27 (defun ensure-accessor (fun-name)
  28   (when (member fun-name *!temporary-ensure-accessor-functions* :test 'equal)
  29     (error "ENSURE-ACCESSOR ~S called more than once!?" fun-name))
  30   (push fun-name *!temporary-ensure-accessor-functions*)
  31   #| We don't really need "fast" global slot accessors while building PCL.
  32   ;; With few exceptions, all methods use a permutation vector for slot access.
  33   ;; In a pinch, these would suffice, should it become utterly necessary:
  34   (destructuring-bind (slot-name method) (cddr fun-name)
  35     (setf (fdefinition fun-name)
  36           (ecase method
  37             (reader (lambda (object) (slot-value object slot-name)))
  38             (writer (lambda (newval object) (setf (slot-value object slot-name) newval)))
  39             (boundp (lambda (object) (slot-boundp object slot-name)))
  40             (makunbound (lambda (object) (slot-makunbound object slot-name))))))|#
  41   (setf (fdefinition fun-name)
  42         (lambda (&rest args)
  43           (error "Nooooo! ~S accidentally invoked on ~S" fun-name args))))
  44
  45 (defun make-structure-slot-value-function (slotd)
  46   (if (slot-definition-always-bound-p slotd)
  47       (slot-definition-internal-reader-function slotd)
  48       (named-lambda checking-slot-value (object)
  49         (let ((value (funcall (slot-definition-internal-reader-function slotd) object)))
  50           (if (unbound-marker-p value)
  51               (values (slot-unbound (class-of object) object (slot-definition-name slotd)))
  52               value)))))
  53
  54 (defun make-structure-slot-boundp-function (slotd)
  55   (if (slot-definition-always-bound-p slotd)
  56       (named-lambda always-bound (object)
  57         (declare (ignore object))
  58         t)
  59       (named-lambda checking-slot-boundp (object)
  60         (not (unbound-marker-p
  61               (funcall (slot-definition-internal-reader-function slotd) object))))))
  62
  63 (defun make-structure-slot-makunbound-function (slotd)
  64   (if (slot-definition-always-bound-p slotd)
  65       (named-lambda cannot-makunbound (object)
  66         (error "Cannot unbind slot ~S in structure ~S" (slot-definition-name slotd) object))
  67       (named-lambda can-makunbound (object)
  68         (funcall (slot-definition-internal-writer-function slotd)
  69                  sb-pcl:+slot-unbound+ object)
  70         object)))
  71
  72 (define-condition instance-structure-protocol-error
  73     (reference-condition error)
  74   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
  75    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
  76   (:report
  77    (lambda (c s)
  78      (format s "~@<The slot ~S has neither ~S nor ~S ~
  79                 allocation, so it can't be ~A by the default ~
  80                 ~S method.~@:>"
  81              (instance-structure-protocol-error-slotd c)
  82              :instance :class
  83              (cond
  84                ((member (instance-structure-protocol-error-fun c)
  85                         '(slot-value-using-class slot-boundp-using-class))
  86                 "read")
  87                (t "written"))
  88              (instance-structure-protocol-error-fun c)))))
  89
  90 (defun instance-structure-protocol-error (slotd fun)
  91   (error 'instance-structure-protocol-error
  92          :slotd slotd :fun fun
  93          :references `((:amop :generic-function ,fun)
  94                        (:amop :section (5 5 3)))))
  95
  96 (defun get-optimized-std-accessor-method-function (class slotd name)
  97   (cond
  98     ((structure-class-p class)
  99      (ecase name
 100        (reader (make-structure-slot-value-function slotd))
 101        (writer (slot-definition-internal-writer-function slotd))
 102        (boundp (make-structure-slot-boundp-function slotd))
 103        (makunbound (make-structure-slot-makunbound-function slotd))))
 104     ((condition-class-p class)
 105      (let ((info (the slot-info (slot-definition-info slotd))))
 106        (ecase name
 107          (reader (slot-info-reader info))
 108          (writer (slot-info-writer info))
 109          (boundp (slot-info-boundp info))
 110          (makunbound (slot-info-makunbound info)))))
 111     (t
 112      (let* ((fsc-p (cond ((standard-class-p class) nil)
 113                          ((funcallable-standard-class-p class) t)
 114                          ((std-class-p class)
 115                           ;; Shouldn't be using the optimized-std-accessors
 116                           ;; in this case.
 117                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 118                                         name slotd class)
 119                           nil)
 120                          (t (error "~S is not a STANDARD-CLASS." class))))
 121             (slot-name (slot-definition-name slotd))
 122             (location (slot-definition-location slotd))
 123             (function (ecase name
 124                         (reader #'make-optimized-std-reader-method-function)
 125                         (writer #'make-optimized-std-writer-method-function)
 126                         (boundp #'make-optimized-std-boundp-method-function)
 127                         (makunbound #'make-optimized-std-makunbound-method-function)))
 128             ;; KLUDGE: we need this slightly hacky calling convention
 129             ;; for these functions for bootstrapping reasons: see
 130             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 131             ;; 2004-07-12
 132             (value (funcall function fsc-p slotd slot-name location)))
 133        (declare (type function function))
 134        (values value (slot-definition-location slotd))))))
 135
 136 (defun make-optimized-structure-slot-value-using-class-method-function
 137     (function)
 138   (declare (type function function))
 139   (lambda (class object slotd)
 140     (declare (ignore class slotd))
 141     (funcall function object)))
 142
 143 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 144     (function)
 145   (declare (type function function))
 146   (lambda (nv class object slotd)
 147     (declare (ignore class slotd))
 148     (funcall function nv object)))
 149
 150 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 151   (lambda (class object slotd)
 152     (declare (ignore class object slotd))
 153     t))
 154
 155 (defun make-optimized-structure-slot-makunbound-using-class-method-function ()
 156   (lambda (class object slotd)
 157     (declare (ignore class object slotd))
 158     (error "Cannot make structure slots unbound")))
 159
 160 (defun get-optimized-std-slot-value-using-class-method-function
 161     (class slotd name)
 162   (cond
 163     ((structure-class-p class)
 164      (ecase name
 165        (reader (make-optimized-structure-slot-value-using-class-method-function
 166                 (slot-definition-internal-reader-function slotd)))
 167        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 168                 (slot-definition-internal-writer-function slotd)))
 169        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))
 170        (makunbound (make-optimized-structure-slot-makunbound-using-class-method-function))))
 171     ((condition-class-p class)
 172      (let ((info (slot-definition-info slotd)))
 173        (ecase name
 174          (reader
 175           (let ((fun (slot-info-reader info)))
 176             (lambda (class object slotd)
 177               (declare (ignore class slotd))
 178               (funcall fun object))))
 179          (writer
 180           (let ((fun (slot-info-writer info)))
 181             (lambda (new-value class object slotd)
 182               (declare (ignore class slotd))
 183               (funcall fun new-value object))))
 184          (boundp
 185           (let ((fun (slot-info-boundp info)))
 186             (lambda (class object slotd)
 187               (declare (ignore class slotd))
 188               (funcall fun object))))
 189          (makunbound
 190           (let ((fun (slot-info-makunbound info)))
 191             (lambda (class object slotd)
 192               (declare (ignore class slotd))
 193               (funcall fun object)))))))
 194     (t
 195      (let* ((fsc-p (cond ((standard-class-p class) nil)
 196                          ((funcallable-standard-class-p class) t)
 197                          (t (error "~S is not a standard-class" class))))
 198             (function
 199               (ecase name
 200                 (reader
 201                  #'make-optimized-std-slot-value-using-class-method-function)
 202                 (writer
 203                  #'make-optimized-std-setf-slot-value-using-class-method-function)
 204                 (boundp
 205                  #'make-optimized-std-slot-boundp-using-class-method-function)
 206                 (makunbound
 207                  #'make-optimized-std-slot-makunbound-using-class-method-function))))
 208        (declare (type function function))
 209        (values (funcall function fsc-p slotd)
 210                (slot-definition-location slotd))))))
 211
 212 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 213   (let ((location (slot-definition-location slotd))
 214         (slot-name (slot-definition-name slotd)))
 215     (etypecase location
 216       (fixnum (if fsc-p
 217                   (lambda (class instance slotd)
 218                     (declare (ignore slotd))
 219                     (check-obsolete-instance instance)
 220                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 221                                                  location)))
 222                       (if (unbound-marker-p value)
 223                           (values (slot-unbound class instance slot-name))
 224                           value)))
 225                   (lambda (class instance slotd)
 226                     (declare (ignore slotd))
 227                     (check-obsolete-instance instance)
 228                     (let ((value (clos-slots-ref (std-instance-slots instance)
 229                                                  location)))
 230                       (if (unbound-marker-p value)
 231                           (values (slot-unbound class instance slot-name))
 232                           value)))))
 233       (cons (lambda (class instance slotd)
 234               (declare (ignore slotd))
 235               (check-obsolete-instance instance)
 236               (let ((value (cdr location)))
 237                 (if (unbound-marker-p value)
 238                     (values (slot-unbound class instance slot-name))
 239                     value))))
 240       (null
 241        (lambda (class instance slotd)
 242          (declare (ignore class instance))
 243          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 244
 245 (defun make-optimized-std-setf-slot-value-using-class-method-function
 246     (fsc-p slotd)
 247   (let* ((location (slot-definition-location slotd))
 248          (class (slot-definition-class slotd))
 249          (typecheck
 250           (when (safe-p class)
 251             (slot-info-typecheck (slot-definition-info slotd)))))
 252     (macrolet ((make-mf-lambda (&body body)
 253                  `(lambda (nv class instance slotd)
 254                     (declare (ignore class slotd))
 255                     (check-obsolete-instance instance)
 256                     ,@body))
 257                (make-mf-lambdas (&body body)
 258                  ;; Having separate lambdas for the NULL / not-NULL cases of
 259                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
 260                  ;; for CLOS typechecking when it's not in use.
 261                  `(if typecheck
 262                       (make-mf-lambda
 263                        (setf nv (funcall (the function typecheck) nv))
 264                        ,@body)
 265                       (make-mf-lambda
 266                        ,@body))))
 267       (etypecase location
 268         (fixnum
 269          (if fsc-p
 270              (make-mf-lambdas
 271               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 272                     nv))
 273              (make-mf-lambdas
 274               (setf (clos-slots-ref (std-instance-slots instance) location)
 275                     nv))))
 276         (cons
 277          (make-mf-lambdas (setf (cdr location) nv)))
 278         (null (lambda (nv class instance slotd)
 279                 (declare (ignore nv class instance))
 280                 (instance-structure-protocol-error
 281                  slotd '(setf slot-value-using-class))))))))
 282
 283 (defun make-optimized-std-slot-boundp-using-class-method-function
 284     (fsc-p slotd)
 285   (let ((location (slot-definition-location slotd)))
 286     (etypecase location
 287       (fixnum
 288        (if fsc-p
 289            (lambda (class instance slotd)
 290              (declare (ignore class slotd))
 291              (check-obsolete-instance instance)
 292              (not (unbound-marker-p
 293                    (clos-slots-ref (fsc-instance-slots instance) location))))
 294            (lambda (class instance slotd)
 295              (declare (ignore class slotd))
 296              (check-obsolete-instance instance)
 297              (not (unbound-marker-p
 298                    (clos-slots-ref (std-instance-slots instance) location))))))
 299       (cons (lambda (class instance slotd)
 300               (declare (ignore class slotd))
 301               (check-obsolete-instance instance)
 302               (not (unbound-marker-p (cdr location)))))
 303       (null
 304        (lambda (class instance slotd)
 305          (declare (ignore class instance))
 306          (instance-structure-protocol-error slotd
 307                                             'slot-boundp-using-class))))))
 308
 309 (defun make-optimized-std-slot-makunbound-using-class-method-function
 310     (fsc-p slotd)
 311   (let ((location (slot-definition-location slotd)))
 312     (etypecase location
 313       (fixnum
 314        (if fsc-p
 315            (lambda (class instance slotd)
 316              (declare (ignore class slotd))
 317              (check-obsolete-instance instance)
 318              (setf (clos-slots-ref (fsc-instance-slots instance) location) +slot-unbound+)
 319              instance)
 320            (lambda (class instance slotd)
 321              (declare (ignore class slotd))
 322              (check-obsolete-instance instance)
 323              (setf (clos-slots-ref (std-instance-slots instance) location) +slot-unbound+)
 324              instance)))
 325       (cons (lambda (class instance slotd)
 326               (declare (ignore class slotd))
 327               (check-obsolete-instance instance)
 328               (setf (cdr location) +slot-unbound+)
 329               instance))
 330       (null
 331        (lambda (class instance slotd)
 332          (declare (ignore class instance))
 333          (instance-structure-protocol-error slotd 'slot-makunbound-using-class))))))
 334
 335 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 336   (macrolet ((emf-funcall (emf &rest args)
 337                `(invoke-effective-method-function ,emf nil
 338                                                   :required-args ,args)))
 339     (set-fun-name
 340      (case name
 341        (reader (lambda (instance)
 342                  (emf-funcall sdfun class instance slotd)))
 343        (writer (lambda (nv instance)
 344                  (emf-funcall sdfun nv class instance slotd)))
 345        (boundp (lambda (instance)
 346                  (emf-funcall sdfun class instance slotd)))
 347        (makunbound (lambda (instance)
 348                      (emf-funcall sdfun class instance slotd))))
 349      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 350 \f
 351 (defun maybe-class (class-or-name)
 352   (when (eq **boot-state** 'complete)
 353     (if (typep class-or-name 'class)
 354         class-or-name
 355         (find-class class-or-name nil))))
 356
 357 (flet ((make-initargs (slot-name kind method-function)
 358          (let ((initargs (copy-tree method-function))
 359                (slot-names (list slot-name)))
 360            (setf (getf (getf initargs 'plist) :slot-name-lists)
 361                  (ecase kind
 362                    ((:reader :boundp :makunbound) (list slot-names))
 363                    (:writer (list '() slot-names))))
 364            initargs)))
 365
 366   (defun make-std-reader-method-function (class-or-name slot-name)
 367     (let ((class (maybe-class class-or-name)))
 368       (make-initargs
 369        slot-name :reader
 370        (ecase (slot-access-strategy class slot-name 'reader t)
 371          (:standard
 372           (make-method-function
 373            (lambda (instance)
 374              (pv-binding1 ((sb-impl::unreachable)
 375                            (instance) (instance-slots))
 376                (instance-read-standard
 377                 .pv. instance-slots 0
 378                 (slot-value instance slot-name))))))
 379          ((:custom :accessor)
 380           (make-method-function
 381            (lambda (instance)
 382              (pv-binding1 ((sb-impl::unreachable)
 383                            (instance) nil)
 384                (instance-read-custom .pv. 0 instance)))))))))
 385
 386   (defun make-std-writer-method-function (class-or-name slot-name)
 387     (let ((class (maybe-class class-or-name)))
 388       (make-initargs
 389        slot-name :writer
 390        (ecase (slot-access-strategy class slot-name 'writer t)
 391          (:standard
 392           (macrolet ((writer-method-function (safe)
 393                        `(make-method-function
 394                          (lambda (nv instance)
 395                            (pv-binding1 ((sb-impl::unreachable)
 396                                          (instance) (instance-slots))
 397                              (instance-write-standard
 398                               .pv. instance-slots 0 nv
 399                               (setf (slot-value instance slot-name)
 400                                     .good-new-value.)
 401                               ,@(when safe '(nil t))))))))
 402             (if (and class (safe-p class))
 403                 (writer-method-function t)
 404                 (writer-method-function nil))))
 405          ((:custom :accessor)
 406           (make-method-function
 407            (lambda (nv instance)
 408              (pv-binding1 ((sb-impl::unreachable)
 409                            (instance) nil)
 410                (instance-write-custom .pv. 0 instance nv)))))))))
 411
 412   (defun make-std-boundp-method-function (class-or-name slot-name)
 413     (let ((class (maybe-class class-or-name)))
 414       (make-initargs
 415        slot-name :boundp
 416        (ecase (slot-access-strategy class slot-name 'boundp t)
 417          (:standard
 418           (make-method-function
 419            (lambda (instance)
 420              (pv-binding1 ((sb-impl::unreachable)
 421                            (instance) (instance-slots))
 422                (instance-boundp-standard
 423                 .pv. instance-slots 0
 424                 (slot-boundp instance slot-name))))))
 425          ((:custom :accessor)
 426           (make-method-function
 427            (lambda (instance)
 428              (pv-binding1 ((sb-impl::unreachable)
 429                            (instance) nil)
 430                (instance-boundp-custom .pv. 0 instance)))))))))
 431
 432   (defun make-std-makunbound-method-function (class-or-name slot-name)
 433     (let ((class (maybe-class class-or-name)))
 434       (make-initargs
 435        slot-name :makunbound
 436        (ecase (slot-access-strategy class slot-name 'makunbound t)
 437          (:standard
 438           (make-method-function
 439            (lambda (instance)
 440              (pv-binding1 ((sb-impl::unreachable)
 441                            (instance) (instance-slots))
 442                           (instance-makunbound-standard
 443                            .pv. instance-slots 0 instance
 444                            (slot-makunbound instance slot-name))))))
 445          ((:custom :accessor)
 446           (make-method-function
 447            (lambda (instance)
 448              (pv-binding1 ((sb-impl::unreachable)
 449                            (instance) nil)
 450                (instance-makunbound-custom .pv. 0 instance)))))))))
 451
 452   (defun make-fallback-reader-method-function (slot-name)
 453     (make-initargs
 454      slot-name :reader
 455      (make-method-function
 456       (lambda (instance)
 457         (slot-value instance slot-name)))))
 458
 459   (defun make-fallback-writer-method-function (slot-name)
 460     (make-initargs
 461      slot-name :writer
 462      (make-method-function
 463       (lambda (nv instance)
 464         (setf (slot-value instance slot-name) nv)))))
 465
 466   (defun make-fallback-boundp-method-function (slot-name)
 467     (make-initargs
 468      slot-name :boundp
 469      (make-method-function
 470       (lambda (instance)
 471         (slot-boundp instance slot-name)))))
 472
 473   (defun make-fallback-makunbound-method-function (slot-name)
 474     (make-initargs
 475      slot-name :makunbound
 476      (make-method-function
 477       (lambda (instance)
 478         (slot-makunbound instance slot-name))))))