X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fslots.lisp;h=1919d3b188037aa17692058a055dc5db441aeac2;hb=0223f43d5f199914ebceff12b6f4c60448369edd;hp=ed6c25ada55aeb52d93f6b1772cc478d1496f433;hpb=8f52542e9da8faa2c2650d37e8cba0f13c3b1c0a;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index ed6c25a..1919d3b 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,11 @@ (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) - (let* ((wrapper (check-obsolete-instance/wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-value))))) (location (car cell)) (value (cond ((fixnump location) @@ -107,19 +101,17 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((not cell) - (return-from 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)))) + (funcall (slot-info-reader (cdr cell)) object))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (if (eq +slot-unbound+ value) (slot-unbound (wrapper-class* wrapper) object slot-name) value))) +;;; This is used during the PCL build, but gets replaced by a deftransform +;;; in fixup.lisp. (define-compiler-macro slot-value (&whole form object slot-name &environment env) (if (and (constantp slot-name env) @@ -128,12 +120,16 @@ form)) (defun set-slot-value (object slot-name new-value) - (let* ((wrapper (check-obsolete-instance/wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from set-slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'setf new-value))))) (location (car cell)) - (type-check-function (cadr cell))) - (when type-check-function - (funcall (the function type-check-function) new-value)) + (info (cdr cell)) + (typecheck (slot-info-typecheck info))) + (when typecheck + (funcall typecheck new-value)) (cond ((fixnump location) (if (std-instance-p object) (setf (standard-instance-access object location) new-value) @@ -141,11 +137,8 @@ new-value))) ((consp location) (setf (cdr location) new-value)) - ((not cell) - (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)) + (funcall (slot-info-writer info) new-value object)) (t (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) new-value) @@ -157,6 +150,8 @@ (defun safe-set-slot-value (object slot-name new-value) (set-slot-value object slot-name new-value)) +;;; This is used during the PCL build, but gets replaced by a deftransform +;;; in fixup.lisp. (define-compiler-macro set-slot-value (&whole form object slot-name new-value &environment env) (if (and (constantp slot-name env) @@ -171,8 +166,12 @@ form)) (defun slot-boundp (object slot-name) - (let* ((wrapper (check-obsolete-instance/wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from slot-boundp + (and (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-boundp) + t)))) (location (car cell)) (value (cond ((fixnump location) @@ -181,14 +180,9 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((not cell) - (return-from slot-boundp - (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)))) + (funcall (slot-info-boundp (cdr cell)) object))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (not (eq +slot-unbound+ value)))) @@ -201,7 +195,7 @@ form)) (defun slot-makunbound (object slot-name) - (let* ((wrapper (check-obsolete-instance/wrapper-of object)) + (let* ((wrapper (valid-wrapper-of object)) (cell (find-slot-cell wrapper slot-name)) (location (car cell))) (cond ((fixnump location) @@ -214,7 +208,8 @@ ((not cell) (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound)) ((not location) - (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell))) + (let ((class (wrapper-class* wrapper))) + (slot-makunbound-using-class class object (find-slot-definition class slot-name)))) (t (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) object) @@ -267,29 +262,27 @@ ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) - (let ((location (slot-definition-location slotd)) - (type-check-function - (when (safe-p class) - (slot-definition-type-check-function slotd)))) - (flet ((check (new-value) - (when type-check-function - (funcall (the function type-check-function) new-value)) - new-value)) - (typecase location - (fixnum - (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - (check new-value))) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - (check new-value))) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) - (cons - (setf (cdr location) (check new-value))) - (t - (instance-structure-protocol-error - slotd '(setf slot-value-using-class))))))) + (let* ((info (slot-definition-info slotd)) + (location (slot-definition-location slotd)) + (typecheck (slot-info-typecheck info)) + (new-value (if typecheck + (funcall (the function typecheck) new-value) + new-value))) + (typecase location + (fixnum + (cond ((std-instance-p object) + (setf (clos-slots-ref (std-instance-slots object) location) + new-value)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + new-value)) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) + (cons + (setf (cdr location) new-value)) + (t + (instance-structure-protocol-error + slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class std-class) @@ -344,8 +337,7 @@ ((class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-reader-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-reader (slot-definition-info slotd)))) (funcall fun object))) (defmethod (setf slot-value-using-class) @@ -353,16 +345,14 @@ (class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-writer-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-writer (slot-definition-info slotd)))) (funcall fun new-value object))) (defmethod slot-boundp-using-class ((class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-boundp-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-boundp (slot-definition-info slotd)))) (funcall fun object))) (defmethod slot-makunbound-using-class ((class condition-class) object slot) @@ -435,7 +425,7 @@ instance (etypecase position (fixnum - (nth position (wrapper-instance-slots-layout (wrapper-of instance)))) + (car (nth position (wrapper-instance-slots-layout (wrapper-of instance))))) (cons (car position)))))) @@ -453,7 +443,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. @@ -465,3 +455,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)))))