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