src/pcl/slots.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 ;;;; ANSI CL condition for unbound slots
  27
  28 (define-condition unbound-slot (cell-error)
  29   ((instance :reader unbound-slot-instance :initarg :instance))
  30   (:report (lambda (condition stream)
  31              (format stream "The slot ~S is unbound in the object ~S."
  32                      (cell-error-name condition)
  33                      (unbound-slot-instance condition)))))
  34
  35 (defmethod wrapper-fetcher ((class standard-class))
  36   'std-instance-wrapper)
  37
  38 (defmethod slots-fetcher ((class standard-class))
  39   'std-instance-slots)
  40
  41 (defmethod raw-instance-allocator ((class standard-class))
  42   'allocate-standard-instance)
  43
  44 ;;; These four functions work on std-instances and fsc-instances. These are
  45 ;;; instances for which it is possible to change the wrapper and the slots.
  46 ;;;
  47 ;;; For these kinds of instances, most specified methods from the instance
  48 ;;; structure protocol are promoted to the implementation-specific class
  49 ;;; std-class. Many of these methods call these four functions.
  50
  51 (defun set-wrapper (inst new)
  52   (cond ((std-instance-p inst)
  53          (setf (std-instance-wrapper inst) new))
  54         ((fsc-instance-p inst)
  55          (setf (fsc-instance-wrapper inst) new))
  56         (t
  57          (error "unrecognized instance type"))))
  58
  59 (defun swap-wrappers-and-slots (i1 i2)
  60   (with-pcl-lock                        ;FIXME is this sufficient?
  61    (cond ((std-instance-p i1)
  62           (let ((w1 (std-instance-wrapper i1))
  63                 (s1 (std-instance-slots i1)))
  64             (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
  65             (setf (std-instance-slots i1) (std-instance-slots i2))
  66             (setf (std-instance-wrapper i2) w1)
  67             (setf (std-instance-slots i2) s1)))
  68          ((fsc-instance-p i1)
  69           (let ((w1 (fsc-instance-wrapper i1))
  70                 (s1 (fsc-instance-slots i1)))
  71             (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
  72             (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
  73             (setf (fsc-instance-wrapper i2) w1)
  74             (setf (fsc-instance-slots i2) s1)))
  75          (t
  76           (error "unrecognized instance type")))))
  77 \f
  78 ;;;; STANDARD-INSTANCE-ACCESS
  79
  80 (declaim (inline standard-instance-access (setf standard-instance-access)
  81                  funcallable-standard-instance-access
  82                  (setf funcallable-standard-instance-access)))
  83
  84 (defun standard-instance-access (instance location)
  85   (clos-slots-ref (std-instance-slots instance) location))
  86
  87 (defun (setf standard-instance-access) (new-value instance location)
  88   (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
  89
  90 (defun funcallable-standard-instance-access (instance location)
  91   (clos-slots-ref (fsc-instance-slots instance) location))
  92
  93 (defun (setf funcallable-standard-instance-access) (new-value instance location)
  94   (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
  95 \f
  96 ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
  97
  98 (declaim (ftype (sfunction (t symbol) t) slot-value))
  99 (defun slot-value (object slot-name)
 100   (let* ((class (check-obsolete-instance/class-of object))
 101          (cell (find-slot-cell class slot-name))
 102          (location (car cell))
 103          (value
 104           (cond ((fixnump location)
 105                  (if (std-instance-p object)
 106                      (standard-instance-access object location)
 107                      (funcallable-standard-instance-access object location)))
 108                 ((consp location)
 109                  (cdr location))
 110                 ((eq t location)
 111                  (return-from slot-value
 112                    (slot-value-using-class class object (cddr cell))))
 113                 ((not cell)
 114                  (return-from slot-value
 115                    (values (slot-missing class object slot-name 'slot-value))))
 116                 (t
 117                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
 118     (if (eq +slot-unbound+ value)
 119         (slot-unbound class object slot-name)
 120         value)))
 121
 122 (define-compiler-macro slot-value (&whole form object slot-name
 123                                    &environment env)
 124   (if (and (constantp slot-name env)
 125            (interned-symbol-p (constant-form-value slot-name env)))
 126       `(accessor-slot-value ,object ,slot-name)
 127       form))
 128
 129 (defun set-slot-value (object slot-name new-value)
 130   (let* ((class (check-obsolete-instance/class-of object))
 131          (cell (find-slot-cell class slot-name))
 132          (location (car cell))
 133          (type-check-function (cadr cell)))
 134     (when type-check-function
 135       (funcall (the function type-check-function) new-value))
 136     (cond ((fixnump location)
 137            (if (std-instance-p object)
 138                (setf (standard-instance-access object location) new-value)
 139                (setf (funcallable-standard-instance-access object location)
 140                      new-value)))
 141           ((consp location)
 142            (setf (cdr location) new-value))
 143           ((eq t location)
 144            (setf (slot-value-using-class class object (cddr cell)) new-value))
 145           ((not cell)
 146            (slot-missing class object slot-name 'setf new-value))
 147           (t
 148            (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
 149   new-value)
 150
 151 ;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
 152 ;;; check types when writing to slots:
 153 ;;;   * Doesn't have an optimizing compiler-macro
 154 ;;;   * Isn't special-cased in WALK-METHOD-LAMBDA
 155 (defun safe-set-slot-value (object slot-name new-value)
 156   (set-slot-value object slot-name new-value))
 157
 158 (define-compiler-macro set-slot-value (&whole form object slot-name new-value
 159                                       &environment env)
 160   (if (and (constantp slot-name env)
 161            (interned-symbol-p (constant-form-value slot-name env))
 162            ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe
 163            ;; code, since it'll use the global automatically generated
 164            ;; accessor, which won't do typechecking. (SLOT-OBJECT
 165            ;; won't have been compiled with SAFETY 3, so SAFE-P will
 166            ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION).
 167            (not (safe-code-p env)))
 168       `(accessor-set-slot-value ,object ,slot-name ,new-value)
 169       form))
 170
 171 (defun slot-boundp (object slot-name)
 172   (let* ((class (check-obsolete-instance/class-of object))
 173          (cell (find-slot-cell class slot-name))
 174          (location (car cell))
 175          (value
 176           (cond ((fixnump location)
 177                  (if (std-instance-p object)
 178                      (standard-instance-access object location)
 179                      (funcallable-standard-instance-access object location)))
 180                 ((consp location)
 181                  (cdr location))
 182                 ((eq t location)
 183                  (return-from slot-boundp
 184                    (slot-boundp-using-class class object (cddr cell))))
 185                 ((not cell)
 186                  (return-from slot-boundp
 187                    (and (slot-missing class object slot-name 'slot-boundp) t)))
 188                 (t
 189                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
 190     (not (eq +slot-unbound+ value))))
 191
 192 (define-compiler-macro slot-boundp (&whole form object slot-name
 193                                     &environment env)
 194   (if (and (constantp slot-name env)
 195            (interned-symbol-p (constant-form-value slot-name env)))
 196       `(accessor-slot-boundp ,object ,slot-name)
 197       form))
 198
 199 (defun slot-makunbound (object slot-name)
 200   (let* ((class (check-obsolete-instance/class-of object))
 201          (cell (find-slot-cell class slot-name))
 202          (location (car cell)))
 203     (cond ((fixnump location)
 204            (if (std-instance-p object)
 205                (setf (standard-instance-access object location) +slot-unbound+)
 206                (setf (funcallable-standard-instance-access object location)
 207                      +slot-unbound+)))
 208           ((consp location)
 209            (setf (cdr location) +slot-unbound+))
 210           ((eq t location)
 211            (slot-makunbound-using-class class object (cddr cell)))
 212           ((not cell)
 213            (slot-missing class object slot-name 'slot-makunbound))
 214           (t
 215            (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
 216   object)
 217
 218 (defun slot-exists-p (object slot-name)
 219   (let ((class (class-of object)))
 220     (not (null (find-slot-definition class slot-name)))))
 221
 222 (defvar *unbound-slot-value-marker* (make-unprintable-object "unbound slot"))
 223
 224 ;;; This isn't documented, but is used within PCL in a number of print
 225 ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
 226 (defun slot-value-or-default (object slot-name &optional
 227                               (default *unbound-slot-value-marker*))
 228   (if (slot-boundp object slot-name)
 229       (slot-value object slot-name)
 230       default))
 231
 232 (defmethod slot-value-using-class ((class std-class)
 233                                    (object standard-object)
 234                                    (slotd standard-effective-slot-definition))
 235   ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
 236   ;; instances. Are users allowed to call this directly?
 237   (check-obsolete-instance object)
 238   (let* ((location (slot-definition-location slotd))
 239          (value
 240           (typecase location
 241             (fixnum
 242              (cond ((std-instance-p object)
 243                     (clos-slots-ref (std-instance-slots object)
 244                                     location))
 245                    ((fsc-instance-p object)
 246                     (clos-slots-ref (fsc-instance-slots object)
 247                                     location))
 248                    (t (bug "unrecognized instance type in ~S"
 249                            'slot-value-using-class))))
 250             (cons
 251              (cdr location))
 252             (t
 253              (instance-structure-protocol-error slotd
 254                                                 'slot-value-using-class)))))
 255     (if (eq value +slot-unbound+)
 256         (values (slot-unbound class object (slot-definition-name slotd)))
 257         value)))
 258
 259 (defmethod (setf slot-value-using-class)
 260            (new-value (class std-class)
 261                       (object standard-object)
 262                       (slotd standard-effective-slot-definition))
 263   ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
 264   ;; instances. Are users allowed to call this directly?
 265   (check-obsolete-instance object)
 266   (let ((location (slot-definition-location slotd))
 267         (type-check-function
 268          (when (safe-p class)
 269            (slot-definition-type-check-function slotd))))
 270     (flet ((check (new-value)
 271              (when type-check-function
 272                (funcall (the function type-check-function) new-value))
 273              new-value))
 274       (typecase location
 275         (fixnum
 276          (cond ((std-instance-p object)
 277                 (setf (clos-slots-ref (std-instance-slots object) location)
 278                       (check new-value)))
 279                ((fsc-instance-p object)
 280                 (setf (clos-slots-ref (fsc-instance-slots object) location)
 281                       (check new-value)))
 282                 (t (bug "unrecognized instance type in ~S"
 283                         '(setf slot-value-using-class)))))
 284         (cons
 285          (setf (cdr location) (check new-value)))
 286         (t
 287          (instance-structure-protocol-error
 288           slotd '(setf slot-value-using-class)))))))
 289
 290 (defmethod slot-boundp-using-class
 291            ((class std-class)
 292             (object standard-object)
 293             (slotd standard-effective-slot-definition))
 294   ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
 295   ;; instances. Are users allowed to call this directly?
 296   (check-obsolete-instance object)
 297   (let* ((location (slot-definition-location slotd))
 298          (value
 299           (typecase location
 300             (fixnum
 301              (cond ((std-instance-p object)
 302                           (clos-slots-ref (std-instance-slots object)
 303                                           location))
 304                    ((fsc-instance-p object)
 305                     (clos-slots-ref (fsc-instance-slots object)
 306                                     location))
 307                    (t (bug "unrecognized instance type in ~S"
 308                            'slot-boundp-using-class))))
 309             (cons
 310              (cdr location))
 311             (t
 312              (instance-structure-protocol-error slotd
 313                                                 'slot-boundp-using-class)))))
 314     (not (eq value +slot-unbound+))))
 315
 316 (defmethod slot-makunbound-using-class
 317            ((class std-class)
 318             (object standard-object)
 319             (slotd standard-effective-slot-definition))
 320   (check-obsolete-instance object)
 321   (let ((location (slot-definition-location slotd)))
 322     (typecase location
 323       (fixnum
 324        (cond ((std-instance-p object)
 325               (setf (clos-slots-ref (std-instance-slots object) location)
 326                     +slot-unbound+))
 327              ((fsc-instance-p object)
 328               (setf (clos-slots-ref (fsc-instance-slots object) location)
 329                     +slot-unbound+))
 330              (t (bug "unrecognized instance type in ~S"
 331                      'slot-makunbound-using-class))))
 332       (cons
 333        (setf (cdr location) +slot-unbound+))
 334       (t
 335        (instance-structure-protocol-error slotd
 336                                           'slot-makunbound-using-class))))
 337   object)
 338
 339 (defmethod slot-value-using-class
 340     ((class condition-class)
 341      (object condition)
 342      (slotd condition-effective-slot-definition))
 343   (let ((fun (slot-definition-reader-function slotd)))
 344     (declare (type function fun))
 345     (funcall fun object)))
 346
 347 (defmethod (setf slot-value-using-class)
 348     (new-value
 349      (class condition-class)
 350      (object condition)
 351      (slotd condition-effective-slot-definition))
 352   (let ((fun (slot-definition-writer-function slotd)))
 353     (declare (type function fun))
 354     (funcall fun new-value object)))
 355
 356 (defmethod slot-boundp-using-class
 357     ((class condition-class)
 358      (object condition)
 359      (slotd condition-effective-slot-definition))
 360   (let ((fun (slot-definition-boundp-function slotd)))
 361     (declare (type function fun))
 362     (funcall fun object)))
 363
 364 (defmethod slot-makunbound-using-class ((class condition-class) object slot)
 365   (error "attempt to unbind slot ~S in condition object ~S."
 366          slot object))
 367
 368 (defmethod slot-value-using-class
 369     ((class structure-class)
 370      (object structure-object)
 371      (slotd structure-effective-slot-definition))
 372   (let* ((function (slot-definition-internal-reader-function slotd))
 373          (value (funcall function object)))
 374     (declare (type function function))
 375     (if (eq value +slot-unbound+)
 376         (values (slot-unbound class object (slot-definition-name slotd)))
 377         value)))
 378
 379 (defmethod (setf slot-value-using-class)
 380     (new-value (class structure-class)
 381                (object structure-object)
 382                (slotd structure-effective-slot-definition))
 383   (let ((function (slot-definition-internal-writer-function slotd)))
 384     (declare (type function function))
 385     (funcall function new-value object)))
 386
 387 (defmethod slot-boundp-using-class
 388            ((class structure-class)
 389             (object structure-object)
 390             (slotd structure-effective-slot-definition))
 391   t)
 392
 393 (defmethod slot-makunbound-using-class
 394            ((class structure-class)
 395             (object structure-object)
 396             (slotd structure-effective-slot-definition))
 397   (error "Structure slots can't be unbound."))
 398 \f
 399 (defmethod slot-missing
 400            ((class t) instance slot-name operation &optional new-value)
 401   (error "~@<When attempting to ~A, the slot ~S is missing from the ~
 402           object ~S.~@:>"
 403          (ecase operation
 404            (slot-value "read the slot's value (slot-value)")
 405            (setf (format nil
 406                          "set the slot's value to ~S (SETF of SLOT-VALUE)"
 407                          new-value))
 408            (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)")
 409            (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)"))
 410          slot-name
 411          instance))
 412
 413 (defmethod slot-unbound ((class t) instance slot-name)
 414   (restart-case
 415       (error 'unbound-slot :name slot-name :instance instance)
 416     (use-value (v)
 417       :report "Return a value as the slot-value."
 418       :interactive read-evaluated-form
 419       v)
 420     (store-value (v)
 421       :report "Store and return a value as the slot-value."
 422       :interactive read-evaluated-form
 423       (setf (slot-value instance slot-name) v))))
 424
 425 (defun slot-unbound-internal (instance position)
 426   (values
 427    (slot-unbound
 428     (class-of instance)
 429     instance
 430     (etypecase position
 431       (fixnum
 432        (nth position (wrapper-instance-slots-layout (wrapper-of instance))))
 433       (cons
 434        (car position))))))
 435 \f
 436 ;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance
 437 ;;; if the class is not yet finalized, but we don't seem to be taking
 438 ;;; care of this for non-standard-classes.x
 439 (defmethod allocate-instance ((class standard-class) &rest initargs)
 440   (declare (ignore initargs))
 441   (unless (class-finalized-p class)
 442     (finalize-inheritance class))
 443   (allocate-standard-instance (class-wrapper class)))
 444
 445 (defmethod allocate-instance ((class structure-class) &rest initargs)
 446   (declare (ignore initargs))
 447   (let ((constructor (class-defstruct-constructor class)))
 448     (if constructor
 449         (funcall constructor)
 450         (allocate-standard-instance (class-wrapper class)))))
 451
 452 ;;; FIXME: It would be nicer to have allocate-instance return
 453 ;;; uninitialized objects for conditions as well.
 454 (defmethod allocate-instance ((class condition-class) &rest initargs)
 455   (declare (ignore initargs))
 456   (make-condition (class-name class)))
 457
 458 (defmethod allocate-instance ((class built-in-class) &rest initargs)
 459   (declare (ignore initargs))
 460   (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
 461