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