src/pcl/slots-boot.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3
   4 ;;;; This software is derived from software originally released by Xerox
   5 ;;;; Corporation. Copyright and release statements follow. Later modifications
   6 ;;;; to the software are in the public domain and are provided with
   7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
   8 ;;;; information.
   9
  10 ;;;; copyright information from original PCL sources:
  11 ;;;;
  12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  13 ;;;; All rights reserved.
  14 ;;;;
  15 ;;;; Use and copying of this software and preparation of derivative works based
  16 ;;;; upon this software are permitted. Any distribution of this software or
  17 ;;;; derivative works must comply with all applicable United States export
  18 ;;;; control laws.
  19 ;;;;
  20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  21 ;;;; warranty about the software, its performance or its conformity to any
  22 ;;;; specification.
  23
  24 (in-package "SB-PCL")
  25 \f
  26 (let ((reader-specializers '(slot-object))
  27       (writer-specializers '(t slot-object)))
  28   (defun ensure-accessor (type fun-name slot-name)
  29     (unless (fboundp fun-name)
  30       (multiple-value-bind (lambda-list specializers method-class initargs doc)
  31           (ecase type
  32             ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
  33             ;; behaviour for non-slot-objects too?
  34             (reader
  35              (values '(object) reader-specializers 'global-reader-method
  36                      (make-std-reader-method-function 'slot-object slot-name)
  37                      "automatically-generated reader method"))
  38             (writer
  39              (values '(new-value object) writer-specializers
  40                      'global-writer-method
  41                      (make-std-writer-method-function 'slot-object slot-name)
  42                      "automatically-generated writer method"))
  43             (boundp
  44              (values '(object) reader-specializers 'global-boundp-method
  45                      (make-std-boundp-method-function 'slot-object slot-name)
  46                      "automatically-generated boundp method")))
  47         (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
  48           (add-method gf (make-a-method method-class
  49                                         () lambda-list specializers
  50                                         initargs doc :slot-name slot-name)))))
  51     t)
  52   ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented
  53   ;; by CSR in June 2007.  Making the bootstrap sane is getting higher
  54   ;; on the "TODO: URGENT" list.
  55   (defun !fix-ensure-accessor-specializers ()
  56     (setf reader-specializers (mapcar #'find-class reader-specializers))
  57     (setf writer-specializers (mapcar #'find-class writer-specializers))))
  58
  59 (defmacro accessor-slot-value (object slot-name)
  60   (aver (constantp slot-name))
  61   (let* ((slot-name (constant-form-value slot-name))
  62          (reader-name (slot-reader-name slot-name)))
  63     `(let ((.ignore. (load-time-value
  64                       (ensure-accessor 'reader ',reader-name ',slot-name))))
  65       (declare (ignore .ignore.))
  66       (truly-the (values t &optional)
  67                  (funcall #',reader-name ,object)))))
  68
  69 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  70   (aver (constantp slot-name))
  71   (setq object (macroexpand object env))
  72   (setq slot-name (macroexpand slot-name env))
  73   (let* ((slot-name (constant-form-value slot-name))
  74          (bindings (unless (or (constantp new-value) (atom new-value))
  75                      (let ((object-var (gensym)))
  76                        (prog1 `((,object-var ,object))
  77                          (setq object object-var)))))
  78          (writer-name (slot-writer-name slot-name))
  79          (form
  80           `(let ((.ignore.
  81                   (load-time-value
  82                    (ensure-accessor 'writer ',writer-name ',slot-name)))
  83                  (.new-value. ,new-value))
  84             (declare (ignore .ignore.))
  85             (funcall #',writer-name .new-value. ,object)
  86             .new-value.)))
  87     (if bindings
  88         `(let ,bindings ,form)
  89         form)))
  90
  91 (defmacro accessor-slot-boundp (object slot-name)
  92   (aver (constantp slot-name))
  93   (let* ((slot-name (constant-form-value slot-name))
  94          (boundp-name (slot-boundp-name slot-name)))
  95     `(let ((.ignore. (load-time-value
  96                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
  97       (declare (ignore .ignore.))
  98       (funcall #',boundp-name ,object))))
  99
 100 (defun make-structure-slot-boundp-function (slotd)
 101   (declare (ignore slotd))
 102   (lambda (object)
 103     (declare (ignore object))
 104     t))
 105
 106 (define-condition instance-structure-protocol-error
 107     (reference-condition error)
 108   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
 109    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
 110   (:report
 111    (lambda (c s)
 112      (format s "~@<The slot ~S has neither ~S nor ~S ~
 113                 allocation, so it can't be ~A by the default ~
 114                 ~S method.~@:>"
 115              (instance-structure-protocol-error-slotd c)
 116              :instance :class
 117              (cond
 118                ((member (instance-structure-protocol-error-fun c)
 119                         '(slot-value-using-class slot-boundp-using-class))
 120                 "read")
 121                (t "written"))
 122              (instance-structure-protocol-error-fun c)))))
 123
 124 (defun instance-structure-protocol-error (slotd fun)
 125   (error 'instance-structure-protocol-error
 126          :slotd slotd :fun fun
 127          :references (list `(:amop :generic-function ,fun)
 128                            '(:amop :section (5 5 3)))))
 129
 130 (defun get-optimized-std-accessor-method-function (class slotd name)
 131   (cond
 132     ((structure-class-p class)
 133      (ecase name
 134        (reader (slot-definition-internal-reader-function slotd))
 135        (writer (slot-definition-internal-writer-function slotd))
 136        (boundp (make-structure-slot-boundp-function slotd))))
 137     ((condition-class-p class)
 138      (ecase name
 139        (reader (slot-definition-reader-function slotd))
 140        (writer (slot-definition-writer-function slotd))
 141        (boundp (slot-definition-boundp-function slotd))))
 142     (t
 143      (let* ((fsc-p (cond ((standard-class-p class) nil)
 144                          ((funcallable-standard-class-p class) t)
 145                          ((std-class-p class)
 146                           ;; Shouldn't be using the optimized-std-accessors
 147                           ;; in this case.
 148                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
 149                                         name slotd class)
 150                           nil)
 151                          (t (error "~S is not a STANDARD-CLASS." class))))
 152             (slot-name (slot-definition-name slotd))
 153             (location (slot-definition-location slotd))
 154             (function (ecase name
 155                         (reader #'make-optimized-std-reader-method-function)
 156                         (writer #'make-optimized-std-writer-method-function)
 157                         (boundp #'make-optimized-std-boundp-method-function)))
 158             ;; KLUDGE: we need this slightly hacky calling convention
 159             ;; for these functions for bootstrapping reasons: see
 160             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
 161             ;; 2004-07-12
 162             (value (funcall function fsc-p slotd slot-name location)))
 163        (declare (type function function))
 164        (values value (slot-definition-location slotd))))))
 165
 166 (defun make-optimized-std-reader-method-function
 167     (fsc-p slotd slot-name location)
 168   (declare #.*optimize-speed*)
 169   (set-fun-name
 170    (etypecase location
 171      (fixnum
 172       (if fsc-p
 173           (lambda (instance)
 174             (check-obsolete-instance instance)
 175             (let ((value (clos-slots-ref (fsc-instance-slots instance)
 176                                          location)))
 177               (if (eq value +slot-unbound+)
 178                   (values
 179                    (slot-unbound (class-of instance) instance slot-name))
 180                   value)))
 181           (lambda (instance)
 182             (check-obsolete-instance instance)
 183             (let ((value (clos-slots-ref (std-instance-slots instance)
 184                                          location)))
 185               (if (eq value +slot-unbound+)
 186                   (values
 187                    (slot-unbound (class-of instance) instance slot-name))
 188                   value)))))
 189      (cons
 190       (lambda (instance)
 191         (check-obsolete-instance instance)
 192         (let ((value (cdr location)))
 193           (if (eq value +slot-unbound+)
 194               (values (slot-unbound (class-of instance) instance slot-name))
 195               value))))
 196      (null
 197       (lambda (instance)
 198         (instance-structure-protocol-error slotd 'slot-value-using-class))))
 199    `(reader ,slot-name)))
 200
 201 (defun make-optimized-std-writer-method-function
 202     (fsc-p slotd slot-name location)
 203   (declare #.*optimize-speed*)
 204   (let* ((safe-p (and slotd
 205                       (slot-definition-class slotd)
 206                       (safe-p (slot-definition-class slotd))))
 207          (writer-fun (etypecase location
 208                        (fixnum (if fsc-p
 209                                    (lambda (nv instance)
 210                                      (check-obsolete-instance instance)
 211                                      (setf (clos-slots-ref (fsc-instance-slots instance)
 212                                                            location)
 213                                            nv))
 214                                    (lambda (nv instance)
 215                                      (check-obsolete-instance instance)
 216                                      (setf (clos-slots-ref (std-instance-slots instance)
 217                                                            location)
 218                                            nv))))
 219                        (cons (lambda (nv instance)
 220                                (check-obsolete-instance instance)
 221                                (setf (cdr location) nv)))
 222                        (null
 223                         (lambda (nv instance)
 224                           (declare (ignore nv instance))
 225                           (instance-structure-protocol-error
 226                            slotd
 227                            '(setf slot-value-using-class))))))
 228          (checking-fun (lambda (new-value instance)
 229                          (check-obsolete-instance instance)
 230                          ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
 231                          (let* (;; Note that this CLASS is not neccessarily
 232                                 ;; the SLOT-DEFINITION-CLASS of the
 233                                 ;; SLOTD passed to M-O-S-W-M-F, since it's
 234                                 ;; e.g. possible for a subclass to define
 235                                 ;; a slot of the same name but with no
 236                                 ;; accessors. So we need to fetch the SLOTD
 237                                 ;; when CHECKING-FUN is called, instead of
 238                                 ;; just closing over it.
 239                                 (class (class-of instance))
 240                                 (slotd (find-slot-definition class slot-name))
 241                                 (type-check-function
 242                                  (when slotd
 243                                    (slot-definition-type-check-function slotd))))
 244                            (when type-check-function
 245                              (funcall type-check-function new-value)))
 246                          ;; Then call the real writer.
 247                          (funcall writer-fun new-value instance))))
 248     (set-fun-name (if safe-p
 249                       checking-fun
 250                       writer-fun)
 251                   `(writer ,slot-name))))
 252
 253 (defun make-optimized-std-boundp-method-function
 254     (fsc-p slotd slot-name location)
 255   (declare #.*optimize-speed*)
 256   (set-fun-name
 257    (etypecase location
 258      (fixnum (if fsc-p
 259                  (lambda (instance)
 260                    (check-obsolete-instance instance)
 261                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 262                                             location)
 263                             +slot-unbound+)))
 264                  (lambda (instance)
 265                    (check-obsolete-instance instance)
 266                    (not (eq (clos-slots-ref (std-instance-slots instance)
 267                                             location)
 268                             +slot-unbound+)))))
 269      (cons (lambda (instance)
 270              (check-obsolete-instance instance)
 271              (not (eq (cdr location) +slot-unbound+))))
 272      (null
 273       (lambda (instance)
 274         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
 275    `(boundp ,slot-name)))
 276
 277 (defun make-optimized-structure-slot-value-using-class-method-function
 278     (function)
 279   (declare (type function function))
 280   (lambda (class object slotd)
 281     (declare (ignore class slotd))
 282     (funcall function object)))
 283
 284 (defun make-optimized-structure-setf-slot-value-using-class-method-function
 285     (function)
 286   (declare (type function function))
 287   (lambda (nv class object slotd)
 288     (declare (ignore class slotd))
 289     (funcall function nv object)))
 290
 291 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 292   (lambda (class object slotd)
 293     (declare (ignore class object slotd))
 294     t))
 295
 296 (defun get-optimized-std-slot-value-using-class-method-function
 297     (class slotd name)
 298   (cond
 299     ((structure-class-p class)
 300      (ecase name
 301        (reader (make-optimized-structure-slot-value-using-class-method-function
 302                 (slot-definition-internal-reader-function slotd)))
 303        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 304                 (slot-definition-internal-writer-function slotd)))
 305        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
 306     ((condition-class-p class)
 307      (ecase name
 308        (reader
 309         (let ((fun (slot-definition-reader-function slotd)))
 310           (declare (type function fun))
 311           (lambda (class object slotd)
 312             (declare (ignore class slotd))
 313             (funcall fun object))))
 314        (writer
 315         (let ((fun (slot-definition-writer-function slotd)))
 316           (declare (type function fun))
 317           (lambda (new-value class object slotd)
 318             (declare (ignore class slotd))
 319             (funcall fun new-value object))))
 320        (boundp
 321         (let ((fun (slot-definition-boundp-function slotd)))
 322           (declare (type function fun))
 323           (lambda (class object slotd)
 324             (declare (ignore class slotd))
 325             (funcall fun object))))))
 326     (t
 327      (let* ((fsc-p (cond ((standard-class-p class) nil)
 328                          ((funcallable-standard-class-p class) t)
 329                          (t (error "~S is not a standard-class" class))))
 330             (function
 331              (ecase name
 332                (reader
 333                 #'make-optimized-std-slot-value-using-class-method-function)
 334                (writer
 335                 #'make-optimized-std-setf-slot-value-using-class-method-function)
 336                (boundp
 337                 #'make-optimized-std-slot-boundp-using-class-method-function))))
 338        (declare (type function function))
 339        (values (funcall function fsc-p slotd)
 340                (slot-definition-location slotd))))))
 341
 342 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
 343   (declare #.*optimize-speed*)
 344   (let ((location (slot-definition-location slotd))
 345         (slot-name (slot-definition-name slotd)))
 346     (etypecase location
 347       (fixnum (if fsc-p
 348                   (lambda (class instance slotd)
 349                     (declare (ignore slotd))
 350                     (check-obsolete-instance instance)
 351                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
 352                                                  location)))
 353                       (if (eq value +slot-unbound+)
 354                           (values (slot-unbound class instance slot-name))
 355                           value)))
 356                   (lambda (class instance slotd)
 357                     (declare (ignore slotd))
 358                     (check-obsolete-instance instance)
 359                     (let ((value (clos-slots-ref (std-instance-slots instance)
 360                                                  location)))
 361                       (if (eq value +slot-unbound+)
 362                           (values (slot-unbound class instance slot-name))
 363                           value)))))
 364       (cons (lambda (class instance slotd)
 365               (declare (ignore slotd))
 366               (check-obsolete-instance instance)
 367               (let ((value (cdr location)))
 368                 (if (eq value +slot-unbound+)
 369                     (values (slot-unbound class instance slot-name))
 370                     value))))
 371       (null
 372        (lambda (class instance slotd)
 373          (declare (ignore class instance))
 374          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 375
 376 (defun make-optimized-std-setf-slot-value-using-class-method-function
 377     (fsc-p slotd)
 378   (declare #.*optimize-speed*)
 379   (let ((location (slot-definition-location slotd))
 380         (type-check-function
 381          (when (and slotd
 382                     (slot-definition-class slotd)
 383                     (safe-p (slot-definition-class slotd)))
 384            (slot-definition-type-check-function slotd))))
 385     (macrolet ((make-mf-lambda (&body body)
 386                  `(lambda (nv class instance slotd)
 387                     (declare (ignore class slotd))
 388                     (check-obsolete-instance instance)
 389                     ,@body))
 390                (make-mf-lambdas (&body body)
 391                  ;; Having separate lambdas for the NULL / not-NULL cases of
 392                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
 393                  ;; for CLOS typechecking when it's not in use.
 394                  `(if type-check-function
 395                       (make-mf-lambda
 396                        (funcall (the function type-check-function) nv)
 397                        ,@body)
 398                       (make-mf-lambda
 399                        ,@body))))
 400       (etypecase location
 401         (fixnum
 402          (if fsc-p
 403              (make-mf-lambdas
 404               (setf (clos-slots-ref (fsc-instance-slots instance) location)
 405                     nv))
 406              (make-mf-lambdas
 407               (setf (clos-slots-ref (std-instance-slots instance) location)
 408                     nv))))
 409         (cons
 410          (make-mf-lambdas (setf (cdr location) nv)))
 411         (null (lambda (nv class instance slotd)
 412                 (declare (ignore nv class instance))
 413                 (instance-structure-protocol-error
 414                  slotd '(setf slot-value-using-class))))))))
 415
 416 (defun make-optimized-std-slot-boundp-using-class-method-function
 417     (fsc-p slotd)
 418   (declare #.*optimize-speed*)
 419   (let ((location (slot-definition-location slotd)))
 420     (etypecase location
 421       (fixnum
 422        (if fsc-p
 423            (lambda (class instance slotd)
 424              (declare (ignore class slotd))
 425              (check-obsolete-instance instance)
 426              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
 427                       +slot-unbound+)))
 428            (lambda (class instance slotd)
 429              (declare (ignore class slotd))
 430              (check-obsolete-instance instance)
 431              (not (eq (clos-slots-ref (std-instance-slots instance) location)
 432                       +slot-unbound+)))))
 433       (cons (lambda (class instance slotd)
 434               (declare (ignore class slotd))
 435               (check-obsolete-instance instance)
 436               (not (eq (cdr location) +slot-unbound+))))
 437       (null
 438        (lambda (class instance slotd)
 439          (declare (ignore class instance))
 440          (instance-structure-protocol-error slotd
 441                                             'slot-boundp-using-class))))))
 442
 443 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 444   (macrolet ((emf-funcall (emf &rest args)
 445                `(invoke-effective-method-function ,emf nil
 446                                                   :required-args ,args)))
 447     (set-fun-name
 448      (case name
 449        (reader (lambda (instance)
 450                  (emf-funcall sdfun class instance slotd)))
 451        (writer (lambda (nv instance)
 452                  (emf-funcall sdfun nv class instance slotd)))
 453        (boundp (lambda (instance)
 454                  (emf-funcall sdfun class instance slotd))))
 455      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 456 \f
 457 (defun make-std-reader-method-function (class-or-name slot-name)
 458   (declare (ignore class-or-name))
 459   (let* ((initargs (copy-tree
 460                     (make-method-function
 461                      (lambda (instance)
 462                        (pv-binding1 (.pv. .calls.
 463                                           (bug "Please report this")
 464                                           (instance) (instance-slots))
 465                          (instance-read-internal
 466                           .pv. instance-slots 0
 467                           (slot-value instance slot-name))))))))
 468     (setf (getf (getf initargs 'plist) :slot-name-lists)
 469           (list (list nil slot-name)))
 470     initargs))
 471
 472 (defun make-std-writer-method-function (class-or-name slot-name)
 473   (let* ((class (when (eq *boot-state* 'complete)
 474                   (if (typep class-or-name 'class)
 475                       class-or-name
 476                       (find-class class-or-name nil))))
 477          (safe-p (and class
 478                       (safe-p class)))
 479          (check-fun (lambda (new-value instance)
 480                       (let* ((class (class-of instance))
 481                              (slotd (find-slot-definition class slot-name))
 482                              (type-check-function
 483                               (when slotd
 484                                 (slot-definition-type-check-function slotd))))
 485                         (when type-check-function
 486                           (funcall type-check-function new-value)))))
 487          (initargs (copy-tree
 488                     (if safe-p
 489                         (make-method-function
 490                          (lambda (nv instance)
 491                            (funcall check-fun nv instance)
 492                            (pv-binding1 (.pv. .calls.
 493                                               (bug "Please report this")
 494                                               (instance) (instance-slots))
 495                              (instance-write-internal
 496                               .pv. instance-slots 0 nv
 497                               (setf (slot-value instance slot-name) nv)))))
 498                         (make-method-function
 499                          (lambda (nv instance)
 500                            (pv-binding1 (.pv. .calls.
 501                                               (bug "Please report this")
 502                                               (instance) (instance-slots))
 503                              (instance-write-internal
 504                               .pv. instance-slots 0 nv
 505                               (setf (slot-value instance slot-name) nv)))))))))
 506     (setf (getf (getf initargs 'plist) :slot-name-lists)
 507           (list nil (list nil slot-name)))
 508     initargs))
 509
 510 (defun make-std-boundp-method-function (class-or-name slot-name)
 511   (declare (ignore class-or-name))
 512   (let* ((initargs (copy-tree
 513                     (make-method-function
 514                      (lambda (instance)
 515                        (pv-binding1 (.pv. .calls.
 516                                           (bug "Please report this")
 517                                           (instance) (instance-slots))
 518                           (instance-boundp-internal
 519                            .pv. instance-slots 0
 520                            (slot-boundp instance slot-name))))))))
 521     (setf (getf (getf initargs 'plist) :slot-name-lists)
 522           (list (list nil slot-name)))
 523     initargs))