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