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