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