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 (defmacro asv-funcall (sym slot-name type &rest args)
  27   (declare (ignore type))
  28   `(if (fboundp ',sym)
  29        (,sym ,@args)
  30        (no-slot ',sym ',slot-name)))
  31
  32 (defun no-slot (sym slot-name)
  33   (error "No class has a slot named ~S (~S has no function binding)."
  34          slot-name sym))
  35
  36 (defmacro accessor-slot-value (object slot-name)
  37   (unless (constantp slot-name)
  38     (error "~S requires its slot-name argument to be a constant"
  39            'accessor-slot-value))
  40   (let* ((slot-name (eval slot-name))
  41          (sym (slot-reader-symbol slot-name)))
  42     `(asv-funcall ,sym ,slot-name reader ,object)))
  43
  44 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  45   (unless (constantp slot-name)
  46     (error "~S requires its slot-name argument to be a constant"
  47            'accessor-set-slot-value))
  48   (setq object (macroexpand object env))
  49   (setq slot-name (macroexpand slot-name env))
  50   (let* ((slot-name (eval slot-name))
  51          (bindings (unless (or (constantp new-value) (atom new-value))
  52                      (let ((object-var (gensym)))
  53                        (prog1 `((,object-var ,object))
  54                          (setq object object-var)))))
  55          (sym (slot-writer-symbol slot-name))
  56          (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
  57     (if bindings
  58         `(let ,bindings ,form)
  59         form)))
  60
  61 (defmacro accessor-slot-boundp (object slot-name)
  62   (unless (constantp slot-name)
  63     (error "~S requires its slot-name argument to be a constant"
  64            'accessor-slot-boundp))
  65   (let ((slot-name (eval slot-name)))
  66     `(slot-boundp-normal ,object ',slot-name)))
  67
  68 (defun make-structure-slot-boundp-function (slotd)
  69   (lambda (object) (declare (ignore object)) t))
  70
  71 (defun get-optimized-std-accessor-method-function (class slotd name)
  72   (if (structure-class-p class)
  73       (ecase name
  74         (reader (slot-definition-internal-reader-function slotd))
  75         (writer (slot-definition-internal-writer-function slotd))
  76         (boundp (make-structure-slot-boundp-function slotd)))
  77       (let* ((fsc-p (cond ((standard-class-p class) nil)
  78                           ((funcallable-standard-class-p class) t)
  79                           ((std-class-p class)
  80                            ;; Shouldn't be using the optimized-std-accessors
  81                            ;; in this case.
  82                            #+nil (format t "* warning: ~S ~S~%   ~S~%"
  83                                    name slotd class)
  84                            nil)
  85                           (t (error "~S is not a STANDARD-CLASS." class))))
  86              (slot-name (slot-definition-name slotd))
  87              (index (slot-definition-location slotd))
  88              (function (ecase name
  89                          (reader #'make-optimized-std-reader-method-function)
  90                          (writer #'make-optimized-std-writer-method-function)
  91                          (boundp #'make-optimized-std-boundp-method-function)))
  92              (value (funcall function fsc-p slot-name index)))
  93         (declare (type function function))
  94         (values value index))))
  95
  96 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
  97   (declare #.*optimize-speed*)
  98   (set-fun-name
  99    (etypecase index
 100      (fixnum (if fsc-p
 101                  (lambda (instance)
 102                    (check-obsolete-instance instance)
 103                    (let ((value (clos-slots-ref (fsc-instance-slots instance)
 104                                                 index)))
 105                      (if (eq value +slot-unbound+)
 106                          (slot-unbound (class-of instance) instance slot-name)
 107                          value)))
 108                  (lambda (instance)
 109                    (check-obsolete-instance instance)
 110                    (let ((value (clos-slots-ref (std-instance-slots instance)
 111                                               index)))
 112                      (if (eq value +slot-unbound+)
 113                          (slot-unbound (class-of instance) instance slot-name)
 114                          value)))))
 115      (cons   (lambda (instance)
 116                (check-obsolete-instance instance)
 117                (let ((value (cdr index)))
 118                  (if (eq value +slot-unbound+)
 119                      (slot-unbound (class-of instance) instance slot-name)
 120                      value)))))
 121    `(reader ,slot-name)))
 122
 123 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
 124   (declare #.*optimize-speed*)
 125   (set-fun-name
 126    (etypecase index
 127      (fixnum (if fsc-p
 128                  (lambda (nv instance)
 129                    (check-obsolete-instance instance)
 130                    (setf (clos-slots-ref (fsc-instance-slots instance) index)
 131                          nv))
 132                  (lambda (nv instance)
 133                    (check-obsolete-instance instance)
 134                    (setf (clos-slots-ref (std-instance-slots instance) index)
 135                          nv))))
 136      (cons   (lambda (nv instance)
 137                (check-obsolete-instance instance)
 138                (setf (cdr index) nv))))
 139    `(writer ,slot-name)))
 140
 141 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
 142   (declare #.*optimize-speed*)
 143   (set-fun-name
 144    (etypecase index
 145      (fixnum (if fsc-p
 146                  (lambda (instance)
 147                    (check-obsolete-instance instance)
 148                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
 149                                             index)
 150                             +slot-unbound+)))
 151                  (lambda (instance)
 152                    (check-obsolete-instance instance)
 153                    (not (eq (clos-slots-ref (std-instance-slots instance)
 154                                             index)
 155                             +slot-unbound+)))))
 156      (cons (lambda (instance)
 157              (check-obsolete-instance instance)
 158              (not (eq (cdr index) +slot-unbound+)))))
 159    `(boundp ,slot-name)))
 160
 161 (defun make-optimized-structure-slot-value-using-class-method-function (function)
 162   (declare (type function function))
 163   (lambda (class object slotd)
 164     (declare (ignore class slotd))
 165     (funcall function object)))
 166
 167 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
 168   (declare (type function function))
 169   (lambda (nv class object slotd)
 170     (declare (ignore class slotd))
 171     (funcall function nv object)))
 172
 173 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
 174   (lambda (class object slotd)
 175     (declare (ignore class object slotd))
 176     t))
 177
 178 (defun get-optimized-std-slot-value-using-class-method-function (class
 179                                                                  slotd
 180                                                                  name)
 181   (if (structure-class-p class)
 182       (ecase name
 183         (reader (make-optimized-structure-slot-value-using-class-method-function
 184                  (slot-definition-internal-reader-function slotd)))
 185         (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 186                  (slot-definition-internal-writer-function slotd)))
 187         (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
 188       (let* ((fsc-p (cond ((standard-class-p class) nil)
 189                           ((funcallable-standard-class-p class) t)
 190                           (t (error "~S is not a standard-class" class))))
 191              (slot-name (slot-definition-name slotd))
 192              (index (slot-definition-location slotd))
 193              (function
 194               (ecase name
 195                 (reader
 196                  #'make-optimized-std-slot-value-using-class-method-function)
 197                 (writer
 198                  #'make-optimized-std-setf-slot-value-using-class-method-function)
 199                 (boundp
 200                  #'make-optimized-std-slot-boundp-using-class-method-function))))
 201         (declare (type function function))
 202         (values (funcall function fsc-p slot-name index) index))))
 203
 204 (defun make-optimized-std-slot-value-using-class-method-function
 205     (fsc-p slot-name index)
 206   (declare #.*optimize-speed*)
 207   (etypecase index
 208     (fixnum (if fsc-p
 209                 (lambda (class instance slotd)
 210                   (declare (ignore slotd))
 211                   (check-obsolete-instance instance)
 212                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
 213                                                index)))
 214                     (if (eq value +slot-unbound+)
 215                         (slot-unbound class instance slot-name)
 216                         value)))
 217                 (lambda (class instance slotd)
 218                   (declare (ignore slotd))
 219                   (check-obsolete-instance instance)
 220                   (let ((value (clos-slots-ref (std-instance-slots instance)
 221                                                index)))
 222                     (if (eq value +slot-unbound+)
 223                         (slot-unbound class instance slot-name)
 224                         value)))))
 225     (cons   (lambda (class instance slotd)
 226               (declare (ignore slotd))
 227               (check-obsolete-instance instance)
 228               (let ((value (cdr index)))
 229                 (if (eq value +slot-unbound+)
 230                     (slot-unbound class instance slot-name)
 231                     value))))))
 232
 233 (defun make-optimized-std-setf-slot-value-using-class-method-function
 234     (fsc-p slot-name index)
 235   (declare #.*optimize-speed*)
 236   (declare (ignore slot-name))
 237   (etypecase index
 238     (fixnum (if fsc-p
 239                 (lambda (nv class instance slotd)
 240                   (declare (ignore class slotd))
 241                   (check-obsolete-instance instance)
 242                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
 243                         nv))
 244                 (lambda (nv class instance slotd)
 245                   (declare (ignore class slotd))
 246                   (check-obsolete-instance instance)
 247                   (setf (clos-slots-ref (std-instance-slots instance) index)
 248                         nv))))
 249     (cons  (lambda (nv class instance slotd)
 250              (declare (ignore class slotd))
 251              (check-obsolete-instance instance)
 252              (setf (cdr index) nv)))))
 253
 254 (defun make-optimized-std-slot-boundp-using-class-method-function
 255     (fsc-p slot-name index)
 256   (declare #.*optimize-speed*)
 257   (declare (ignore slot-name))
 258   (etypecase index
 259     (fixnum (if fsc-p
 260                 (lambda (class instance slotd)
 261                   (declare (ignore class slotd))
 262                   (check-obsolete-instance instance)
 263                   (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
 264                            +slot-unbound+)))
 265                 (lambda (class instance slotd)
 266                   (declare (ignore class slotd))
 267                   (check-obsolete-instance instance)
 268                   (not (eq (clos-slots-ref (std-instance-slots instance) index)
 269                            +slot-unbound+)))))
 270     (cons   (lambda (class instance slotd)
 271               (declare (ignore class slotd))
 272               (check-obsolete-instance instance)
 273               (not (eq (cdr index) +slot-unbound+))))))
 274
 275 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
 276   (macrolet ((emf-funcall (emf &rest args)
 277                `(invoke-effective-method-function ,emf nil ,@args)))
 278     (set-fun-name
 279      (case name
 280        (reader (lambda (instance)
 281                  (emf-funcall sdfun class instance slotd)))
 282        (writer (lambda (nv instance)
 283                  (emf-funcall sdfun nv class instance slotd)))
 284        (boundp (lambda (instance)
 285                  (emf-funcall sdfun class instance slotd))))
 286      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 287
 288 (defun make-internal-reader-method-function (class-name slot-name)
 289   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
 290          (make-method-function
 291           (lambda (instance)
 292             (let ((wrapper (get-instance-wrapper-or-nil instance)))
 293               (if wrapper
 294                   (let* ((class (wrapper-class* wrapper))
 295                          (index (or (instance-slot-index wrapper slot-name)
 296                                     (assq slot-name
 297                                           (wrapper-class-slots wrapper)))))
 298                     (typecase index
 299                       (fixnum
 300                        (let ((value (clos-slots-ref (get-slots instance)
 301                                                     index)))
 302                          (if (eq value +slot-unbound+)
 303                              (slot-unbound (class-of instance)
 304                                            instance
 305                                            slot-name)
 306                              value)))
 307                       (cons
 308                        (let ((value (cdr index)))
 309                          (if (eq value +slot-unbound+)
 310                              (slot-unbound (class-of instance)
 311                                            instance
 312                                            slot-name)
 313                              value)))
 314                       (t
 315                        (error "~@<The wrapper for class ~S does not have ~
 316                                the slot ~S~@:>"
 317                               class slot-name))))
 318                   (slot-value instance slot-name)))))))
 319 \f
 320 (defun make-std-reader-method-function (class-name slot-name)
 321   (let* ((pv-table-symbol (gensym))
 322          (initargs (copy-tree
 323                     (make-method-function
 324                      (lambda (instance)
 325                        (pv-binding1 (.pv. .calls.
 326                                           (symbol-value pv-table-symbol)
 327                                           (instance) (instance-slots))
 328                          (instance-read-internal
 329                           .pv. instance-slots 1
 330                           (slot-value instance slot-name))))))))
 331     (setf (getf (getf initargs :plist) :slot-name-lists)
 332           (list (list nil slot-name)))
 333     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 334     (list* :method-spec `(reader-method ,class-name ,slot-name)
 335            initargs)))
 336
 337 (defun make-std-writer-method-function (class-name slot-name)
 338   (let* ((pv-table-symbol (gensym))
 339          (initargs (copy-tree
 340                     (make-method-function
 341                      (lambda (nv instance)
 342                        (pv-binding1 (.pv. .calls.
 343                                           (symbol-value pv-table-symbol)
 344                                           (instance) (instance-slots))
 345                          (instance-write-internal
 346                           .pv. instance-slots 1 nv
 347                           (setf (slot-value instance slot-name) nv))))))))
 348     (setf (getf (getf initargs :plist) :slot-name-lists)
 349           (list nil (list nil slot-name)))
 350     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 351     (list* :method-spec `(writer-method ,class-name ,slot-name)
 352            initargs)))
 353
 354 (defun make-std-boundp-method-function (class-name slot-name)
 355   (let* ((pv-table-symbol (gensym))
 356          (initargs (copy-tree
 357                     (make-method-function
 358                      (lambda (instance)
 359                        (pv-binding1 (.pv. .calls.
 360                                           (symbol-value pv-table-symbol)
 361                                           (instance) (instance-slots))
 362                           (instance-boundp-internal
 363                            .pv. instance-slots 1
 364                            (slot-boundp instance slot-name))))))))
 365     (setf (getf (getf initargs :plist) :slot-name-lists)
 366           (list (list nil slot-name)))
 367     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
 368     (list* :method-spec `(boundp-method ,class-name ,slot-name)
 369            initargs)))
 370
 371 (defun initialize-internal-slot-gfs (slot-name &optional type)
 372   (when (or (null type) (eq type 'reader))
 373     (let* ((name (slot-reader-symbol slot-name))
 374            (gf (ensure-generic-function name)))
 375       (unless (generic-function-methods gf)
 376         (add-reader-method *the-class-slot-object* gf slot-name))))
 377   (when (or (null type) (eq type 'writer))
 378     (let* ((name (slot-writer-symbol slot-name))
 379            (gf (ensure-generic-function name)))
 380       (unless (generic-function-methods gf)
 381         (add-writer-method *the-class-slot-object* gf slot-name))))
 382   nil)
 383
 384 (defun initialize-internal-slot-gfs* (readers writers boundps)
 385   (dolist (reader readers)
 386     (initialize-internal-slot-gfs reader 'reader))
 387   (dolist (writer writers)
 388     (initialize-internal-slot-gfs writer 'writer))
 389   (dolist (boundp boundps)
 390     (initialize-internal-slot-gfs boundp 'boundp)))