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   (if (structure-class-p class)
 134       (ecase name
 135         (reader (slot-definition-internal-reader-function slotd))
 136         (writer (slot-definition-internal-writer-function slotd))
 137         (boundp (make-structure-slot-boundp-function slotd)))
 138       (let* ((fsc-p (cond ((standard-class-p class) nil)
 139                           ((funcallable-standard-class-p class) t)
 140                           ((std-class-p class)
 141                            ;; Shouldn't be using the optimized-std-accessors
 142                            ;; in this case.
 143                            #+nil (format t "* warning: ~S ~S~%   ~S~%"
 144                                    name slotd class)
 145                            nil)
 146                           (t (error "~S is not a STANDARD-CLASS." class))))
 147              (slot-name (slot-definition-name slotd))
 148              (index (slot-definition-location slotd))
 149              (function (ecase name
 150                          (reader #'make-optimized-std-reader-method-function)
 151                          (writer #'make-optimized-std-writer-method-function)
 152                          (boundp #'make-optimized-std-boundp-method-function)))
 153              (value (funcall function fsc-p slot-name index)))
 154         (declare (type function function))
 155         (values value index))))
 156
 157 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
 158   (declare #.*optimize-speed*)
 159   (set-fun-name
 160    (etypecase index
 161      (fixnum (if fsc-p
 162                  (lambda (instance)
 163                    (check-obsolete-instance instance)
 164                    (let ((value (clos-slots-ref (fsc-instance-slots instance)
 165                                                 index)))
 166                      (if (eq value +slot-unbound+)
 167                          (slot-unbound (class-of instance) instance slot-name)
 168                          value)))
 169                  (lambda (instance)
 170                    (check-obsolete-instance instance)
 171                    (let ((value (clos-slots-ref (std-instance-slots instance)
 172                                               index)))
 173                      (if (eq value +slot-unbound+)
 174                          (slot-unbound (class-of instance) instance slot-name)
 175                          value)))))
 176      (cons   (lambda (instance)
 177                (check-obsolete-instance instance)
 178                (let ((value (cdr index)))
 179                  (if (eq value +slot-unbound+)
 180                      (slot-unbound (class-of instance) instance slot-name)
 181                      value)))))
 182    `(reader ,slot-name)))
 183
 184 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
 185   (declare #.*optimize-speed*)
 186   (set-fun-name
 187    (etypecase index
 188      (fixnum (if fsc-p
 189                  (lambda (nv instance)
 190                    (check-obsolete-instance instance)
 191                    (setf (clos-slots-ref (fsc-instance-slots instance) index)
 192                          nv))
 193                  (lambda (nv instance)
 194                    (check-obsolete-instance instance)
 195                    (setf (clos-slots-ref (std-instance-slots instance) index)
 196                          nv))))
 197      (cons   (lambda (nv instance)
 198                (check-obsolete-instance instance)
 199                (setf (cdr index) nv))))
 200    `(writer ,slot-name)))
 201
 202 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
 203   (declare #.*optimize-speed*)
 204   (set-fun-name
 205    (etypecase index
 206      (fixnum (if fsc-p
 207                  (lambda (instance)
 208                    (check-obsolete-instance instance)
 209                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 210                                             index)
 211                             +slot-unbound+)))
 212                  (lambda (instance)
 213                    (check-obsolete-instance instance)
 214                    (not (eq (clos-slots-ref (std-instance-slots instance)
 215                                             index)
 216                             +slot-unbound+)))))
 217      (cons (lambda (instance)
 218              (check-obsolete-instance instance)
 219              (not (eq (cdr index) +slot-unbound+)))))
 220    `(boundp ,slot-name)))
 221
 222 (defun make-optimized-structure-slot-value-using-class-method-function (function)
 223   (declare (type function function))
 224   (lambda (class object slotd)
 225     (declare (ignore class slotd))
 226     (funcall function object)))
 227
 228 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
 229   (declare (type function function))
 230   (lambda (nv class object slotd)
 231     (declare (ignore class slotd))
 232     (funcall function nv object)))
 233
 234 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 235   (lambda (class object slotd)
 236     (declare (ignore class object slotd))
 237     t))
 238
 239 (defun get-optimized-std-slot-value-using-class-method-function (class
 240                                                                  slotd
 241                                                                  name)
 242   (if (structure-class-p class)
 243       (ecase name
 244         (reader (make-optimized-structure-slot-value-using-class-method-function
 245                  (slot-definition-internal-reader-function slotd)))
 246         (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 247                  (slot-definition-internal-writer-function slotd)))
 248         (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
 249       (let* ((fsc-p (cond ((standard-class-p class) nil)
 250                           ((funcallable-standard-class-p class) t)
 251                           (t (error "~S is not a standard-class" class))))
 252              (slot-name (slot-definition-name slotd))
 253              (index (slot-definition-location slotd))
 254              (function
 255               (ecase name
 256                 (reader
 257                  #'make-optimized-std-slot-value-using-class-method-function)
 258                 (writer
 259                  #'make-optimized-std-setf-slot-value-using-class-method-function)
 260                 (boundp
 261                  #'make-optimized-std-slot-boundp-using-class-method-function))))
 262         (declare (type function function))
 263         (values (funcall function fsc-p slot-name index) index))))
 264
 265 (defun make-optimized-std-slot-value-using-class-method-function
 266     (fsc-p slot-name index)
 267   (declare #.*optimize-speed*)
 268   (etypecase index
 269     (fixnum (if fsc-p
 270                 (lambda (class instance slotd)
 271                   (declare (ignore slotd))
 272                   (check-obsolete-instance instance)
 273                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
 274                                                index)))
 275                     (if (eq value +slot-unbound+)
 276                         (slot-unbound class instance slot-name)
 277                         value)))
 278                 (lambda (class instance slotd)
 279                   (declare (ignore slotd))
 280                   (check-obsolete-instance instance)
 281                   (let ((value (clos-slots-ref (std-instance-slots instance)
 282                                                index)))
 283                     (if (eq value +slot-unbound+)
 284                         (slot-unbound class instance slot-name)
 285                         value)))))
 286     (cons   (lambda (class instance slotd)
 287               (declare (ignore slotd))
 288               (check-obsolete-instance instance)
 289               (let ((value (cdr index)))
 290                 (if (eq value +slot-unbound+)
 291                     (slot-unbound class instance slot-name)
 292                     value))))))
 293
 294 (defun make-optimized-std-setf-slot-value-using-class-method-function
 295     (fsc-p slot-name index)
 296   (declare #.*optimize-speed*)
 297   (declare (ignore slot-name))
 298   (etypecase index
 299     (fixnum (if fsc-p
 300                 (lambda (nv class instance slotd)
 301                   (declare (ignore class slotd))
 302                   (check-obsolete-instance instance)
 303                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
 304                         nv))
 305                 (lambda (nv class instance slotd)
 306                   (declare (ignore class slotd))
 307                   (check-obsolete-instance instance)
 308                   (setf (clos-slots-ref (std-instance-slots instance) index)
 309                         nv))))
 310     (cons  (lambda (nv class instance slotd)
 311              (declare (ignore class slotd))
 312              (check-obsolete-instance instance)
 313              (setf (cdr index) nv)))))
 314
 315 (defun make-optimized-std-slot-boundp-using-class-method-function
 316     (fsc-p slot-name index)
 317   (declare #.*optimize-speed*)
 318   (declare (ignore slot-name))
 319   (etypecase index
 320     (fixnum (if fsc-p
 321                 (lambda (class instance slotd)
 322                   (declare (ignore class slotd))
 323                   (check-obsolete-instance instance)
 324                   (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
 325                            +slot-unbound+)))
 326                 (lambda (class instance slotd)
 327                   (declare (ignore class slotd))
 328                   (check-obsolete-instance instance)
 329                   (not (eq (clos-slots-ref (std-instance-slots instance) index)
 330                            +slot-unbound+)))))
 331     (cons   (lambda (class instance slotd)
 332               (declare (ignore class slotd))
 333               (check-obsolete-instance instance)
 334               (not (eq (cdr index) +slot-unbound+))))))
 335
 336 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 337   (macrolet ((emf-funcall (emf &rest args)
 338                `(invoke-effective-method-function ,emf nil ,@args)))
 339     (set-fun-name
 340      (case name
 341        (reader (lambda (instance)
 342                  (emf-funcall sdfun class instance slotd)))
 343        (writer (lambda (nv instance)
 344                  (emf-funcall sdfun nv class instance slotd)))
 345        (boundp (lambda (instance)
 346                  (emf-funcall sdfun class instance slotd))))
 347      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 348
 349 (defun make-internal-reader-method-function (class-name slot-name)
 350   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
 351          (make-method-function
 352           (lambda (instance)
 353             (let ((wrapper (get-instance-wrapper-or-nil instance)))
 354               (if wrapper
 355                   (let* ((class (wrapper-class* wrapper))
 356                          (index (or (instance-slot-index wrapper slot-name)
 357                                     (assq slot-name
 358                                           (wrapper-class-slots wrapper)))))
 359                     (typecase index
 360                       (fixnum
 361                        (let ((value (clos-slots-ref (get-slots instance)
 362                                                     index)))
 363                          (if (eq value +slot-unbound+)
 364                              (slot-unbound (class-of instance)
 365                                            instance
 366                                            slot-name)
 367                              value)))
 368                       (cons
 369                        (let ((value (cdr index)))
 370                          (if (eq value +slot-unbound+)
 371                              (slot-unbound (class-of instance)
 372                                            instance
 373                                            slot-name)
 374                              value)))
 375                       (t
 376                        (error "~@<The wrapper for class ~S does not have ~
 377                                the slot ~S~@:>"
 378                               class slot-name))))
 379                   (slot-value instance slot-name)))))))
 380 \f
 381 (defun make-std-reader-method-function (class-name slot-name)
 382   (let* ((pv-table-symbol (gensym))
 383          (initargs (copy-tree
 384                     (make-method-function
 385                      (lambda (instance)
 386                        (pv-binding1 (.pv. .calls.
 387                                           (symbol-value pv-table-symbol)
 388                                           (instance) (instance-slots))
 389                          (instance-read-internal
 390                           .pv. instance-slots 1
 391                           (slot-value instance slot-name))))))))
 392     (setf (getf (getf initargs :plist) :slot-name-lists)
 393           (list (list nil slot-name)))
 394     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 395     (list* :method-spec `(reader-method ,class-name ,slot-name)
 396            initargs)))
 397
 398 (defun make-std-writer-method-function (class-name slot-name)
 399   (let* ((pv-table-symbol (gensym))
 400          (initargs (copy-tree
 401                     (make-method-function
 402                      (lambda (nv instance)
 403                        (pv-binding1 (.pv. .calls.
 404                                           (symbol-value pv-table-symbol)
 405                                           (instance) (instance-slots))
 406                          (instance-write-internal
 407                           .pv. instance-slots 1 nv
 408                           (setf (slot-value instance slot-name) nv))))))))
 409     (setf (getf (getf initargs :plist) :slot-name-lists)
 410           (list nil (list nil slot-name)))
 411     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 412     (list* :method-spec `(writer-method ,class-name ,slot-name)
 413            initargs)))
 414
 415 (defun make-std-boundp-method-function (class-name slot-name)
 416   (let* ((pv-table-symbol (gensym))
 417          (initargs (copy-tree
 418                     (make-method-function
 419                      (lambda (instance)
 420                        (pv-binding1 (.pv. .calls.
 421                                           (symbol-value pv-table-symbol)
 422                                           (instance) (instance-slots))
 423                           (instance-boundp-internal
 424                            .pv. instance-slots 1
 425                            (slot-boundp instance slot-name))))))))
 426     (setf (getf (getf initargs :plist) :slot-name-lists)
 427           (list (list nil slot-name)))
 428     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 429     (list* :method-spec `(boundp-method ,class-name ,slot-name)
 430            initargs)))
 431
 432 (defun initialize-internal-slot-gfs (slot-name &optional type)
 433   (macrolet ((frob (type name-fun add-fun)
 434                `(when (or (null type) (eq type ',type))
 435                  (let* ((name (,name-fun slot-name))
 436                         (gf (ensure-generic-function name))
 437                         (methods (generic-function-methods gf)))
 438                    (when (or (null methods)
 439                              (plist-value gf 'slot-missing-method))
 440                      (setf (plist-value gf 'slot-missing-method) nil)
 441                      (,add-fun *the-class-slot-object* gf slot-name))))))
 442     (frob reader slot-reader-name add-reader-method)
 443     (frob writer slot-writer-name add-writer-method)
 444     (frob boundp slot-boundp-name add-boundp-method)))