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