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