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