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
  26 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 (defmacro slot-symbol (slot-name type)
  30   `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
  31        (or (get ,slot-name ',(ecase type
  32                                (reader 'reader-symbol)
  33                                (writer 'writer-symbol)
  34                                (boundp 'boundp-symbol)))
  35            (intern (format nil "~A ~A slot ~A"
  36                            (package-name (symbol-package ,slot-name))
  37                            (symbol-name ,slot-name)
  38                            ,(symbol-name type))
  39                    *slot-accessor-name-package*))
  40        (progn
  41          (error "Non-symbol and non-interned symbol slot name accessors~
  42                  are not yet implemented.")
  43          ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
  44          )))
  45
  46 (defun slot-reader-symbol (slot-name)
  47   (slot-symbol slot-name reader))
  48
  49 (defun slot-writer-symbol (slot-name)
  50   (slot-symbol slot-name writer))
  51
  52 (defun slot-boundp-symbol (slot-name)
  53   (slot-symbol slot-name boundp))
  54
  55 (defmacro asv-funcall (sym slot-name type &rest args)
  56   (declare (ignore type))
  57   `(if (fboundp ',sym)
  58        (,sym ,@args)
  59        (no-slot ',sym ',slot-name)))
  60
  61 (defun no-slot (sym slot-name)
  62   (error "No class has a slot named ~S (~S has no function binding)."
  63          slot-name sym))
  64
  65 (defmacro accessor-slot-value (object slot-name)
  66   (unless (constantp slot-name)
  67     (error "~S requires its slot-name argument to be a constant"
  68            'accessor-slot-value))
  69   (let* ((slot-name (eval slot-name))
  70          (sym (slot-reader-symbol slot-name)))
  71     `(asv-funcall ,sym ,slot-name reader ,object)))
  72
  73 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
  74   (unless (constantp slot-name)
  75     (error "~S requires its slot-name argument to be a constant"
  76            'accessor-set-slot-value))
  77   (setq object (macroexpand object env))
  78   (setq slot-name (macroexpand slot-name env))
  79   (let* ((slot-name (eval slot-name))
  80          (bindings (unless (or (constantp new-value) (atom new-value))
  81                      (let ((object-var (gensym)))
  82                        (prog1 `((,object-var ,object))
  83                          (setq object object-var)))))
  84          (sym (slot-writer-symbol slot-name))
  85          (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
  86     (if bindings
  87         `(let ,bindings ,form)
  88         form)))
  89
  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 (%instance-ref (fsc-instance-slots instance) index)))
 145                        (if (eq value *slot-unbound*)
 146                            (slot-unbound (class-of instance) instance slot-name)
 147                            value)))
 148                  #'(lambda (instance)
 149                      (let ((value (%instance-ref (std-instance-slots instance) index)))
 150                        (if (eq value *slot-unbound*)
 151                            (slot-unbound (class-of instance) instance slot-name)
 152                            value)))))
 153      (cons   #'(lambda (instance)
 154                  (let ((value (cdr index)))
 155                    (if (eq value *slot-unbound*)
 156                        (slot-unbound (class-of instance) instance slot-name)
 157                        value)))))
 158    `(reader ,slot-name)))
 159
 160 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
 161   (declare #.*optimize-speed*)
 162   (set-function-name
 163    (etypecase index
 164      (fixnum (if fsc-p
 165                  #'(lambda (nv instance)
 166                      (setf (%instance-ref (fsc-instance-slots instance) index) nv))
 167                  #'(lambda (nv instance)
 168                      (setf (%instance-ref (std-instance-slots instance) index) nv))))
 169      (cons   #'(lambda (nv instance)
 170                  (declare (ignore instance))
 171                  (setf (cdr index) nv))))
 172    `(writer ,slot-name)))
 173
 174 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
 175   (declare #.*optimize-speed*)
 176   (set-function-name
 177    (etypecase index
 178      (fixnum (if fsc-p
 179                  #'(lambda (instance)
 180                      (not (eq (%instance-ref (fsc-instance-slots instance)
 181                                              index)
 182                               *slot-unbound*)))
 183                  #'(lambda (instance)
 184                      (not (eq (%instance-ref (std-instance-slots instance)
 185                                              index)
 186                               *slot-unbound*)))))
 187      (cons   #'(lambda (instance)
 188                  (declare (ignore instance))
 189                  (not (eq (cdr index) *slot-unbound*)))))
 190    `(boundp ,slot-name)))
 191
 192 (defun make-optimized-structure-slot-value-using-class-method-function (function)
 193   (declare (type function function))
 194   #'(lambda (class object slotd)
 195       (let ((value (funcall function object)))
 196         (if (eq value *slot-unbound*)
 197             (slot-unbound class object (slot-definition-name slotd))
 198             value))))
 199
 200 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
 201   (declare (type function function))
 202   #'(lambda (nv class object slotd)
 203       (declare (ignore class slotd))
 204       (funcall function nv object)))
 205
 206 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
 207   (declare (type function function))
 208   #'(lambda (class object slotd)
 209       (declare (ignore class slotd))
 210       (not (eq (funcall function object) *slot-unbound*))))
 211
 212 (defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
 213   (if (structure-class-p class)
 214       (ecase name
 215         (reader (make-optimized-structure-slot-value-using-class-method-function
 216                  (slot-definition-internal-reader-function slotd)))
 217         (writer (make-optimized-structure-setf-slot-value-using-class-method-function
 218                  (slot-definition-internal-writer-function slotd)))
 219         (boundp (make-optimized-structure-slot-boundp-using-class-method-function
 220                  (slot-definition-internal-writer-function slotd))))
 221       (let* ((fsc-p (cond ((standard-class-p class) nil)
 222                           ((funcallable-standard-class-p class) t)
 223                           (t (error "~S is not a standard-class" class))))
 224              (slot-name (slot-definition-name slotd))
 225              (index (slot-definition-location slotd))
 226              (function
 227               (ecase name
 228                 (reader
 229                  #'make-optimized-std-slot-value-using-class-method-function)
 230                 (writer
 231                  #'make-optimized-std-setf-slot-value-using-class-method-function)
 232                 (boundp
 233                  #'make-optimized-std-slot-boundp-using-class-method-function))))
 234         (declare (type function function))
 235         (values (funcall function fsc-p slot-name index) index))))
 236
 237 (defun make-optimized-std-slot-value-using-class-method-function
 238     (fsc-p slot-name index)
 239   (declare #.*optimize-speed*)
 240   (etypecase index
 241     (fixnum (if fsc-p
 242                 #'(lambda (class instance slotd)
 243                     (declare (ignore slotd))
 244                     (unless (fsc-instance-p instance) (error "not fsc"))
 245                     (let ((value (%instance-ref (fsc-instance-slots instance) index)))
 246                       (if (eq value *slot-unbound*)
 247                           (slot-unbound class instance slot-name)
 248                           value)))
 249                 #'(lambda (class instance slotd)
 250                     (declare (ignore slotd))
 251                     (unless (std-instance-p instance) (error "not std"))
 252                     (let ((value (%instance-ref (std-instance-slots instance) 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 (%instance-ref (fsc-instance-slots instance) index) nv))
 272                 #'(lambda (nv class instance slotd)
 273                     (declare (ignore class slotd))
 274                     (setf (%instance-ref (std-instance-slots instance) index) nv))))
 275     (cons   #'(lambda (nv class instance slotd)
 276                 (declare (ignore class instance slotd))
 277                 (setf (cdr index) nv)))))
 278
 279 (defun make-optimized-std-slot-boundp-using-class-method-function
 280     (fsc-p slot-name index)
 281   (declare #.*optimize-speed*)
 282   (declare (ignore slot-name))
 283   (etypecase index
 284     (fixnum (if fsc-p
 285                 #'(lambda (class instance slotd)
 286                     (declare (ignore class slotd))
 287                     (not (eq (%instance-ref (fsc-instance-slots instance)
 288                                             index)
 289                              *slot-unbound* )))
 290                 #'(lambda (class instance slotd)
 291                     (declare (ignore class slotd))
 292                     (not (eq (%instance-ref (std-instance-slots instance)
 293                                             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) (emf-funcall sdfun class instance slotd)))
 305        (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
 306        (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
 307      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
 308
 309 (defun make-internal-reader-method-function (class-name slot-name)
 310   (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
 311          (make-method-function
 312           (lambda (instance)
 313             (let ((wrapper (get-instance-wrapper-or-nil instance)))
 314               (if wrapper
 315                   (let* ((class (wrapper-class* wrapper))
 316                          (index (or (instance-slot-index wrapper slot-name)
 317                                     (assq slot-name (wrapper-class-slots wrapper)))))
 318                     (typecase index
 319                       (fixnum
 320                        (let ((value (%instance-ref (get-slots instance) index)))
 321                          (if (eq value *slot-unbound*)
 322                              (slot-unbound (class-of instance) instance slot-name)
 323                              value)))
 324                       (cons
 325                        (let ((value (cdr index)))
 326                          (if (eq value *slot-unbound*)
 327                              (slot-unbound (class-of instance) instance slot-name)
 328                              value)))
 329                       (t
 330                        (error "The wrapper for class ~S does not have the slot ~S"
 331                               class slot-name))))
 332                   (slot-value instance slot-name)))))))
 333 \f
 334 (defun make-std-reader-method-function (class-name slot-name)
 335   (let* ((pv-table-symbol (gensym))
 336          (initargs (copy-tree
 337                     (make-method-function
 338                      (lambda (instance)
 339                        (pv-binding1 (.pv. .calls.
 340                                           (symbol-value pv-table-symbol)
 341                                           (instance) (instance-slots))
 342                          (instance-read-internal
 343                           .pv. instance-slots 1
 344                           (slot-value instance slot-name))))))))
 345     (setf (getf (getf initargs ':plist) ':slot-name-lists)
 346           (list (list nil slot-name)))
 347     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
 348     (list* ':method-spec `(reader-method ,class-name ,slot-name)
 349            initargs)))
 350
 351 (defun make-std-writer-method-function (class-name slot-name)
 352   (let* ((pv-table-symbol (gensym))
 353          (initargs (copy-tree
 354                     (make-method-function
 355                      (lambda (nv instance)
 356                        (pv-binding1 (.pv. .calls.
 357                                           (symbol-value pv-table-symbol)
 358                                           (instance) (instance-slots))
 359                          (instance-write-internal
 360                           .pv. instance-slots 1 nv
 361                           (setf (slot-value instance slot-name) nv))))))))
 362     (setf (getf (getf initargs ':plist) ':slot-name-lists)
 363           (list nil (list nil slot-name)))
 364     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
 365     (list* ':method-spec `(writer-method ,class-name ,slot-name)
 366            initargs)))
 367
 368 (defun make-std-boundp-method-function (class-name slot-name)
 369   (let* ((pv-table-symbol (gensym))
 370          (initargs (copy-tree
 371                     (make-method-function
 372                      (lambda (instance)
 373                        (pv-binding1 (.pv. .calls.
 374                                           (symbol-value pv-table-symbol)
 375                                           (instance) (instance-slots))
 376                           (instance-boundp-internal
 377                            .pv. instance-slots 1
 378                            (slot-boundp instance slot-name))))))))
 379     (setf (getf (getf initargs ':plist) ':slot-name-lists)
 380           (list (list nil slot-name)))
 381     (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
 382     (list* ':method-spec `(boundp-method ,class-name ,slot-name)
 383            initargs)))
 384
 385 (defun initialize-internal-slot-gfs (slot-name &optional type)
 386   (when (or (null type) (eq type 'reader))
 387     (let* ((name (slot-reader-symbol slot-name))
 388            (gf (ensure-generic-function name)))
 389       (unless (generic-function-methods gf)
 390         (add-reader-method *the-class-slot-object* gf slot-name))))
 391   (when (or (null type) (eq type 'writer))
 392     (let* ((name (slot-writer-symbol slot-name))
 393            (gf (ensure-generic-function name)))
 394       (unless (generic-function-methods gf)
 395         (add-writer-method *the-class-slot-object* gf slot-name))))
 396   (when (and *optimize-slot-boundp*
 397              (or (null type) (eq type 'boundp)))
 398     (let* ((name (slot-boundp-symbol slot-name))
 399            (gf (ensure-generic-function name)))
 400       (unless (generic-function-methods gf)
 401         (add-boundp-method *the-class-slot-object* gf slot-name))))
 402   nil)
 403
 404 (defun initialize-internal-slot-gfs* (readers writers boundps)
 405   (dolist (reader readers)
 406     (initialize-internal-slot-gfs reader 'reader))
 407   (dolist (writer writers)
 408     (initialize-internal-slot-gfs writer 'writer))
 409   (dolist (boundp boundps)
 410     (initialize-internal-slot-gfs boundp 'boundp)))