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