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