X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=2768a42bcb1c4f23655adf222522e1f98417e851;hb=d25e3478acccec70402ff32554669a982be8e281;hp=7fa30139fcf7056d0a866daada61c78fb2f25a7f;hpb=157e21959c8023f146d6b03206aea6daa60e7b0d;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 7fa3013..2768a42 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -41,39 +41,30 @@ (defmethod raw-instance-allocator ((class standard-class)) 'allocate-standard-instance) -;;; These four functions work on std-instances and fsc-instances. These are +;;; These three functions work on std-instances and fsc-instances. These are ;;; instances for which it is possible to change the wrapper and the slots. ;;; ;;; For these kinds of instances, most specified methods from the instance ;;; structure protocol are promoted to the implementation-specific class ;;; std-class. Many of these methods call these four functions. -(defun set-wrapper (inst new) - (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) new)) +(defun %swap-wrappers-and-slots (i1 i2) + (cond ((std-instance-p i1) + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1))) + ((fsc-instance-p i1) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1))) (t (error "unrecognized instance type")))) - -(defun swap-wrappers-and-slots (i1 i2) - (with-pcl-lock ;FIXME is this sufficient? - (cond ((std-instance-p i1) - (let ((w1 (std-instance-wrapper i1)) - (s1 (std-instance-slots i1))) - (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) - (setf (std-instance-slots i1) (std-instance-slots i2)) - (setf (std-instance-wrapper i2) w1) - (setf (std-instance-slots i2) s1))) - ((fsc-instance-p i1) - (let ((w1 (fsc-instance-wrapper i1)) - (s1 (fsc-instance-slots i1))) - (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) - (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) - (setf (fsc-instance-wrapper i2) w1) - (setf (fsc-instance-slots i2) s1))) - (t - (error "unrecognized instance type"))))) ;;;; STANDARD-INSTANCE-ACCESS @@ -97,8 +88,8 @@ (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) - (let* ((class (check-obsolete-instance/class-of object)) - (cell (find-slot-cell class slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) (location (car cell)) (value (cond ((fixnump location) @@ -107,16 +98,17 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((eq t location) - (return-from slot-value - (slot-value-using-class class object (cddr cell)))) ((not cell) (return-from slot-value - (values (slot-missing class object slot-name 'slot-value)))) + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-value)))) + ((not location) + (return-from slot-value + (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (if (eq +slot-unbound+ value) - (slot-unbound class object slot-name) + (slot-unbound (wrapper-class* wrapper) object slot-name) value))) (define-compiler-macro slot-value (&whole form object slot-name @@ -127,8 +119,8 @@ form)) (defun set-slot-value (object slot-name new-value) - (let* ((class (check-obsolete-instance/class-of object)) - (cell (find-slot-cell class slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) (location (car cell)) (type-check-function (cadr cell))) (when type-check-function @@ -140,10 +132,11 @@ new-value))) ((consp location) (setf (cdr location) new-value)) - ((eq t location) - (setf (slot-value-using-class class object (cddr cell)) new-value)) ((not cell) - (slot-missing class object slot-name 'setf new-value)) + (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value)) + ((not location) + (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)) + new-value)) (t (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) new-value) @@ -169,8 +162,8 @@ form)) (defun slot-boundp (object slot-name) - (let* ((class (check-obsolete-instance/class-of object)) - (cell (find-slot-cell class slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) (location (car cell)) (value (cond ((fixnump location) @@ -179,12 +172,14 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((eq t location) - (return-from slot-boundp - (slot-boundp-using-class class object (cddr cell)))) ((not cell) (return-from slot-boundp - (and (slot-missing class object slot-name 'slot-boundp) t))) + (and (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-boundp) + t))) + ((not location) + (return-from slot-boundp + (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell)))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (not (eq +slot-unbound+ value)))) @@ -197,8 +192,8 @@ form)) (defun slot-makunbound (object slot-name) - (let* ((class (check-obsolete-instance/class-of object)) - (cell (find-slot-cell class slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) (location (car cell))) (cond ((fixnump location) (if (std-instance-p object) @@ -207,10 +202,10 @@ +slot-unbound+))) ((consp location) (setf (cdr location) +slot-unbound+)) - ((eq t location) - (slot-makunbound-using-class class object (cddr cell))) ((not cell) - (slot-missing class object slot-name 'slot-makunbound)) + (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound)) + ((not location) + (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell))) (t (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) object) @@ -372,6 +367,8 @@ (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) (declare (type function function)) + ;; FIXME: Is this really necessary? Structure slots should surely + ;; never be unbound! (if (eq value +slot-unbound+) (values (slot-unbound class object (slot-definition-name slotd))) value))) @@ -447,7 +444,7 @@ (let ((constructor (class-defstruct-constructor class))) (if constructor (funcall constructor) - (allocate-standard-instance (class-wrapper class))))) + (error "Don't know how to allocate ~S" class)))) ;;; FIXME: It would be nicer to have allocate-instance return ;;; uninitialized objects for conditions as well. @@ -459,3 +456,10 @@ (declare (ignore initargs)) (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP +;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. +(defmethod class-slots :before ((class slot-class)) + (unless (class-finalized-p class) + (error 'simple-reference-error + :format-control "~S called on ~S, which is not yet finalized." + :format-arguments (list 'class-slots class) + :references (list '(:amop :generic-function class-slots)))))