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