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