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;;;; 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 (handler-case 32 (format stream "~@<The slot ~/sb-ext:print-symbol-with-prefix/ ~ 33 is unbound in the object ~A.~@:>" 34 (cell-error-name condition) 35 (unbound-slot-instance condition)) 36 (serious-condition () 37 ;; In case of an error try again avoiding custom PRINT-OBJECT's. 38 (format stream "~&Error during printing.~%~@<The slot ~ 39 ~/sb-ext:print-symbol-with-prefix/ ~ 40 is unbound in an instance of ~ 41 ~/sb-ext:print-symbol-with-prefix/.~@:>" 42 (cell-error-name condition) 43 (type-of (unbound-slot-instance condition)))))))) 44 45(defmethod wrapper-fetcher ((class standard-class)) 46 'std-instance-wrapper) 47 48(defmethod slots-fetcher ((class standard-class)) 49 'std-instance-slots) 50 51(defmethod raw-instance-allocator ((class standard-class)) 52 'allocate-standard-instance) 53 54;;; These three functions work on std-instances and fsc-instances. These are 55;;; instances for which it is possible to change the wrapper and the slots. 56;;; 57;;; For these kinds of instances, most specified methods from the instance 58;;; structure protocol are promoted to the implementation-specific class 59;;; std-class. Many of these methods call these four functions. 60 61(defun %swap-wrappers-and-slots (i1 i2) ; old -> new 62 (cond ((std-instance-p i1) 63 #+(and compact-instance-header x86-64) 64 (let ((oslots (std-instance-slots i1)) 65 (nslots (std-instance-slots i2))) 66 ;; The hash val is in the header of the slots. Copying is race-free 67 ;; because it is immutable once memoized by STD-INSTANCE-HASH. 68 (sb-vm::cas-header-data-high 69 nslots 0 (sb-impl::%std-instance-hash oslots))) 70 ;; FIXME: If a backend supports two-word primitive instances 71 ;; and double-wide CAS, it's probably best to use that. 72 ;; Maybe we're inside a mutex here anyway though? 73 (let ((w1 (std-instance-wrapper i1)) 74 (s1 (std-instance-slots i1))) 75 (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) 76 (setf (std-instance-slots i1) (std-instance-slots i2)) 77 (setf (std-instance-wrapper i2) w1) 78 (setf (std-instance-slots i2) s1))) 79 ((fsc-instance-p i1) 80 (let ((w1 (fsc-instance-wrapper i1)) 81 (s1 (fsc-instance-slots i1))) 82 (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) 83 (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) 84 (setf (fsc-instance-wrapper i2) w1) 85 (setf (fsc-instance-slots i2) s1))) 86 (t 87 (error "unrecognized instance type")))) 88 89;;;; STANDARD-INSTANCE-ACCESS 90 91(declaim (inline standard-instance-access 92 (setf standard-instance-access) 93 (cas stadard-instance-access) 94 funcallable-standard-instance-access 95 (setf funcallable-standard-instance-access) 96 (cas funcallable-standard-instance-access))) 97 98(defun standard-instance-access (instance location) 99 (clos-slots-ref (std-instance-slots instance) location)) 100 101(defun (setf standard-instance-access) (new-value instance location) 102 (setf (clos-slots-ref (std-instance-slots instance) location) new-value)) 103 104(defun (cas standard-instance-access) (old-value new-value instance location) 105 ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? 106 (cas (svref (std-instance-slots instance) location) old-value new-value)) 107 108(defun funcallable-standard-instance-access (instance location) 109 (clos-slots-ref (fsc-instance-slots instance) location)) 110 111(defun (setf funcallable-standard-instance-access) (new-value instance location) 112 (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value)) 113 114(defun (cas funcallable-standard-instance-access) (old-value new-value instance location) 115 ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? 116 (cas (svref (fsc-instance-slots instance) location) old-value new-value)) 117 118;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND 119 120(declaim (ftype (sfunction (t symbol) t) slot-value)) 121(defun slot-value (object slot-name) 122 (let* ((wrapper (valid-wrapper-of object)) 123 (cell (find-slot-cell wrapper slot-name)) 124 (location (car cell)) 125 (value 126 (cond ((fixnump location) 127 (if (std-instance-p object) 128 (standard-instance-access object location) 129 (funcallable-standard-instance-access object location))) 130 ((not location) 131 (return-from slot-value 132 (if cell 133 (funcall (slot-info-reader (cdr cell)) object) 134 (values (slot-missing (wrapper-class* wrapper) object 135 slot-name 'slot-value))))) 136 ;; this next test means CONSP, but the transform that weakens 137 ;; CONSP to LISTP isn't working here for some reason. 138 ((listp location) 139 (cdr location)) 140 (t 141 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) 142 (if (eq +slot-unbound+ value) 143 (slot-unbound (wrapper-class* wrapper) object slot-name) 144 value))) 145 146(defun set-slot-value (object slot-name new-value) 147 (let* ((wrapper (valid-wrapper-of object)) 148 (cell (or (find-slot-cell wrapper slot-name) 149 (return-from set-slot-value 150 (progn (slot-missing (wrapper-class* wrapper) 151 object slot-name 'setf new-value) 152 new-value)))) 153 (location (car cell)) 154 (info (cdr cell)) 155 (typecheck (slot-info-typecheck info))) 156 (when typecheck 157 (funcall typecheck new-value)) 158 (cond ((fixnump location) 159 (if (std-instance-p object) 160 (setf (standard-instance-access object location) new-value) 161 (setf (funcallable-standard-instance-access object location) 162 new-value))) 163 ((not location) 164 (funcall (slot-info-writer info) new-value object)) 165 ((listp location) ; forcibly transform CONSP to LISTP 166 (setf (cdr location) new-value)) 167 (t 168 (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) 169 new-value) 170 171;;; A version of SET-SLOT-VALUE for use in safe code, where we want to 172;;; check types when writing to slots: 173;;; * Doesn't have an optimizing compiler-macro 174;;; * Isn't special-cased in WALK-METHOD-LAMBDA 175(defun safe-set-slot-value (object slot-name new-value) 176 (set-slot-value object slot-name new-value)) 177 178(defun (cas slot-value) (old-value new-value object slot-name) 179 (let* ((wrapper (valid-wrapper-of object)) 180 (cell (or (find-slot-cell wrapper slot-name) 181 (return-from slot-value 182 (values (slot-missing (wrapper-class* wrapper) object slot-name 183 'cas (list old-value new-value)))))) 184 (location (car cell)) 185 (info (cdr cell)) 186 (typecheck (slot-info-typecheck info))) 187 (when typecheck 188 (funcall typecheck new-value)) 189 (let ((old (cond ((fixnump location) 190 (if (std-instance-p object) 191 (cas (standard-instance-access object location) old-value new-value) 192 (cas (funcallable-standard-instance-access object location) 193 old-value new-value))) 194 ((not location) 195 ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)... 196 (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object)) 197 ((listp location) ; forcibly transform CONSP to LISTP 198 (cas (cdr location) old-value new-value)) 199 (t 200 (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell))))) 201 (if (and (eq +slot-unbound+ old) 202 (neq old old-value)) 203 (slot-unbound (wrapper-class* wrapper) object slot-name) 204 old)))) 205 206(defun slot-boundp (object slot-name) 207 (let* ((wrapper (valid-wrapper-of object)) 208 (cell (find-slot-cell wrapper slot-name)) 209 (location (car cell)) 210 (value 211 (cond ((fixnump location) 212 (if (std-instance-p object) 213 (standard-instance-access object location) 214 (funcallable-standard-instance-access object location))) 215 ((not location) 216 (return-from slot-boundp 217 (if cell 218 (funcall (slot-info-boundp (cdr cell)) object) 219 (and (slot-missing (wrapper-class* wrapper) object 220 slot-name 'slot-boundp) 221 t)))) 222 ((listp location) ; forcibly transform CONSP to LISTP 223 (cdr location)) 224 (t 225 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) 226 (not (eq +slot-unbound+ value)))) 227 228(defun slot-makunbound (object slot-name) 229 (let* ((wrapper (valid-wrapper-of object)) 230 (cell (find-slot-cell wrapper slot-name)) 231 (location (car cell))) 232 (cond ((fixnump location) 233 (if (std-instance-p object) 234 (setf (standard-instance-access object location) +slot-unbound+) 235 (setf (funcallable-standard-instance-access object location) 236 +slot-unbound+))) 237 ((not location) 238 (if cell 239 (let ((class (wrapper-class* wrapper))) 240 (slot-makunbound-using-class class object 241 (find-slot-definition class slot-name))) 242 (slot-missing (wrapper-class* wrapper) object slot-name 243 'slot-makunbound))) 244 ((listp location) ; forcibly transform CONSP to LISTP 245 (setf (cdr location) +slot-unbound+)) 246 (t 247 (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) 248 object) 249 250;; Note that CLHS "encourages" implementors to base this on 251;; SLOT-EXISTS-P-USING-CLASS, whereas 88-002R made no such claim, 252;; however Appendix D of AMOP sketches out such an implementation. 253(defun slot-exists-p (object slot-name) 254 (not (null (find-slot-cell (valid-wrapper-of object) slot-name)))) 255 256(defun slot-value-for-printing (object slot-name) 257 (if (slot-boundp object slot-name) 258 (slot-value object slot-name) 259 (load-time-value (make-unprintable-object "unbound slot") t))) 260 261(defmethod slot-value-using-class ((class std-class) 262 (object standard-object) 263 (slotd standard-effective-slot-definition)) 264 ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete 265 ;; instances. Are users allowed to call this directly? 266 (check-obsolete-instance object) 267 (let* ((location (slot-definition-location slotd)) 268 (value 269 (typecase location 270 (fixnum 271 (cond ((std-instance-p object) 272 (clos-slots-ref (std-instance-slots object) 273 location)) 274 ((fsc-instance-p object) 275 (clos-slots-ref (fsc-instance-slots object) 276 location)) 277 (t (bug "unrecognized instance type in ~S" 278 'slot-value-using-class)))) 279 (cons 280 (cdr location)) 281 (t 282 (instance-structure-protocol-error slotd 283 'slot-value-using-class))))) 284 (if (eq value +slot-unbound+) 285 (values (slot-unbound class object (slot-definition-name slotd))) 286 value))) 287 288(defmethod (setf slot-value-using-class) 289 (new-value (class std-class) 290 (object standard-object) 291 (slotd standard-effective-slot-definition)) 292 ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete 293 ;; instances. Are users allowed to call this directly? 294 (check-obsolete-instance object) 295 (let* ((info (slot-definition-info slotd)) 296 (location (slot-definition-location slotd)) 297 (typecheck (slot-info-typecheck info)) 298 (new-value (if typecheck 299 (funcall (the function typecheck) new-value) 300 new-value))) 301 (typecase location 302 (fixnum 303 (cond ((std-instance-p object) 304 (setf (clos-slots-ref (std-instance-slots object) location) 305 new-value)) 306 ((fsc-instance-p object) 307 (setf (clos-slots-ref (fsc-instance-slots object) location) 308 new-value)) 309 (t (bug "unrecognized instance type in ~S" 310 '(setf slot-value-using-class))))) 311 (cons 312 (setf (cdr location) new-value)) 313 (t 314 (instance-structure-protocol-error 315 slotd '(setf slot-value-using-class)))))) 316 317(defmethod slot-boundp-using-class 318 ((class std-class) 319 (object standard-object) 320 (slotd standard-effective-slot-definition)) 321 ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete 322 ;; instances. Are users allowed to call this directly? 323 (check-obsolete-instance object) 324 (let* ((location (slot-definition-location slotd)) 325 (value 326 (typecase location 327 (fixnum 328 (cond ((std-instance-p object) 329 (clos-slots-ref (std-instance-slots object) 330 location)) 331 ((fsc-instance-p object) 332 (clos-slots-ref (fsc-instance-slots object) 333 location)) 334 (t (bug "unrecognized instance type in ~S" 335 'slot-boundp-using-class)))) 336 (cons 337 (cdr location)) 338 (t 339 (instance-structure-protocol-error slotd 340 'slot-boundp-using-class))))) 341 (not (eq value +slot-unbound+)))) 342 343(defmethod slot-makunbound-using-class 344 ((class std-class) 345 (object standard-object) 346 (slotd standard-effective-slot-definition)) 347 (check-obsolete-instance object) 348 (let ((location (slot-definition-location slotd))) 349 (typecase location 350 (fixnum 351 (cond ((std-instance-p object) 352 (setf (clos-slots-ref (std-instance-slots object) location) 353 +slot-unbound+)) 354 ((fsc-instance-p object) 355 (setf (clos-slots-ref (fsc-instance-slots object) location) 356 +slot-unbound+)) 357 (t (bug "unrecognized instance type in ~S" 358 'slot-makunbound-using-class)))) 359 (cons 360 (setf (cdr location) +slot-unbound+)) 361 (t 362 (instance-structure-protocol-error slotd 363 'slot-makunbound-using-class)))) 364 object) 365 366(defmethod slot-value-using-class 367 ((class condition-class) 368 (object condition) 369 (slotd condition-effective-slot-definition)) 370 (let ((fun (slot-info-reader (slot-definition-info slotd)))) 371 (funcall fun object))) 372 373(defmethod (setf slot-value-using-class) 374 (new-value 375 (class condition-class) 376 (object condition) 377 (slotd condition-effective-slot-definition)) 378 (let ((fun (slot-info-writer (slot-definition-info slotd)))) 379 (funcall fun new-value object))) 380 381(defmethod slot-boundp-using-class 382 ((class condition-class) 383 (object condition) 384 (slotd condition-effective-slot-definition)) 385 (let ((fun (slot-info-boundp (slot-definition-info slotd)))) 386 (funcall fun object))) 387 388(defmethod slot-makunbound-using-class ((class condition-class) object slot) 389 (error "attempt to unbind slot ~S in condition object ~S." 390 slot object)) 391 392(defmethod slot-value-using-class 393 ((class structure-class) 394 (object structure-object) 395 (slotd structure-effective-slot-definition)) 396 (let* ((function (slot-definition-internal-reader-function slotd)) 397 (value (funcall function object))) 398 (declare (type function function)) 399 ;; FIXME: Is this really necessary? Structure slots should surely 400 ;; never be unbound! 401 (if (eq value +slot-unbound+) 402 (values (slot-unbound class object (slot-definition-name slotd))) 403 value))) 404 405(defmethod (setf slot-value-using-class) 406 (new-value (class structure-class) 407 (object structure-object) 408 (slotd structure-effective-slot-definition)) 409 (let ((function (slot-definition-internal-writer-function slotd))) 410 (declare (type function function)) 411 (funcall function new-value object))) 412 413(defmethod slot-boundp-using-class 414 ((class structure-class) 415 (object structure-object) 416 (slotd structure-effective-slot-definition)) 417 t) 418 419(defmethod slot-makunbound-using-class 420 ((class structure-class) 421 (object structure-object) 422 (slotd structure-effective-slot-definition)) 423 (error "Structure slots can't be unbound.")) 424 425(defmethod slot-missing 426 ((class t) instance slot-name operation &optional new-value) 427 (error "~@<When attempting to ~A, the slot ~S is missing from the ~ 428 object ~S.~@:>" 429 (ecase operation 430 (slot-value "read the slot's value (slot-value)") 431 (setf (format nil 432 "set the slot's value to ~S (SETF of SLOT-VALUE)" 433 new-value)) 434 (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") 435 (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) 436 slot-name 437 instance)) 438 439(defmethod slot-unbound ((class t) instance slot-name) 440 (restart-case 441 (error 'unbound-slot :name slot-name :instance instance) 442 (use-value (v) 443 :report "Return a value as the slot-value." 444 :interactive read-evaluated-form 445 v) 446 (store-value (v) 447 :report "Store and return a value as the slot-value." 448 :interactive read-evaluated-form 449 (setf (slot-value instance slot-name) v)))) 450 451(defun slot-unbound-internal (instance position) 452 (values 453 (slot-unbound 454 (class-of instance) 455 instance 456 (etypecase position 457 (fixnum 458 ;; In the vast majority of cases location corresponds to the position 459 ;; in list. The only exceptions are when there are non-local slots 460 ;; before the one we want. 461 (let* ((slots (layout-slot-list (layout-of instance))) 462 (guess (nth position slots))) 463 (if (eql position (slot-definition-location guess)) 464 (slot-definition-name guess) 465 (slot-definition-name 466 (car (member position (class-slots instance) :key #'slot-definition-location)))))) 467 (cons 468 (car position)))))) 469 470;;; FIXME: AMOP says that allocate-instance implies finalize-inheritance 471;;; if the class is not yet finalized, but we don't seem to be taking 472;;; care of this for non-standard-classes. 473(defmethod allocate-instance ((class standard-class) &rest initargs) 474 (declare (ignore initargs) 475 (inline ensure-class-finalized)) 476 (allocate-standard-instance 477 (class-wrapper (ensure-class-finalized class)))) 478 479(defmethod allocate-instance ((class structure-class) &rest initargs) 480 (declare (ignore initargs)) 481 (let ((constructor (class-defstruct-constructor class))) 482 (if constructor 483 (funcall constructor) 484 (error "Don't know how to allocate ~S" class)))) 485 486(defmethod allocate-instance ((class condition-class) &rest initargs) 487 (declare (ignore initargs)) 488 (values (allocate-condition (class-name class)))) 489 490(defmethod allocate-instance ((class system-class) &rest initargs) 491 (declare (ignore initargs)) 492 (error "Cannot allocate an instance of ~S." class)) 493 494;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. 495(defmethod class-slots :before ((class slot-class)) 496 (unless (class-finalized-p class) 497 (error 'simple-reference-error 498 :format-control "~S called on ~S, which is not yet finalized." 499 :format-arguments (list 'class-slots class) 500 :references (list '(:amop :generic-function class-slots))))) 501 502(defun %set-slots (object names &rest values) 503 (mapc (lambda (name value) 504 (if (eq value +slot-unbound+) 505 ;; SLOT-MAKUNBOUND-USING-CLASS might do something nonstandard. 506 (slot-makunbound object name) 507 (setf (slot-value object name) value))) 508 names values)) 509