X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=2768a42bcb1c4f23655adf222522e1f98417e851;hb=d25e3478acccec70402ff32554669a982be8e281;hp=b9ee30958f3337b6f66aed386633323f9ddd2d29;hpb=a556288505e2687ac333e1b0a8deebb13c76a60c;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index b9ee309..2768a42 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -41,52 +41,75 @@ (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")))) + +;;;; STANDARD-INSTANCE-ACCESS + +(declaim (inline standard-instance-access (setf standard-instance-access) + funcallable-standard-instance-access + (setf funcallable-standard-instance-access))) + +(defun standard-instance-access (instance location) + (clos-slots-ref (std-instance-slots instance) location)) + +(defun (setf standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (std-instance-slots instance) location) new-value)) -(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"))))) +(defun funcallable-standard-instance-access (instance location) + (clos-slots-ref (fsc-instance-slots instance) location)) + +(defun (setf funcallable-standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value)) -(defun find-slot-definition (class slot-name) - (dolist (slot (class-slots class) nil) - (when (eql slot-name (slot-definition-name slot)) - (return slot)))) +;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (values (slot-missing class object slot-name 'slot-value)) - (slot-value-using-class class object slot-definition)))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (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)))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (if (eq +slot-unbound+ value) + (slot-unbound (wrapper-class* wrapper) object slot-name) + value))) (define-compiler-macro slot-value (&whole form object slot-name &environment env) @@ -96,13 +119,27 @@ form)) (defun set-slot-value (object slot-name new-value) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (progn (slot-missing class object slot-name 'setf new-value) - new-value) - (setf (slot-value-using-class class object slot-definition) - new-value)))) + (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 + (funcall (the function type-check-function) new-value)) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) new-value) + (setf (funcallable-standard-instance-access object location) + 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)) + (t + (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) + new-value) ;;; A version of SET-SLOT-VALUE for use in safe code, where we want to ;;; check types when writing to slots: @@ -125,13 +162,27 @@ form)) (defun slot-boundp (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (not (not (slot-missing class object slot-name 'slot-boundp))) - (slot-boundp-using-class class object slot-definition)))) - -(setf (gdefinition 'slot-boundp-normal) #'slot-boundp) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (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)))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (not (eq +slot-unbound+ value)))) (define-compiler-macro slot-boundp (&whole form object slot-name &environment env) @@ -141,12 +192,23 @@ form)) (defun slot-makunbound (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)) - object)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell))) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) +slot-unbound+) + (setf (funcallable-standard-instance-access object location) + +slot-unbound+))) + ((consp location) + (setf (cdr location) +slot-unbound+)) + ((not cell) + (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) (defun slot-exists-p (object slot-name) (let ((class (class-of object))) @@ -161,16 +223,12 @@ (if (slot-boundp object slot-name) (slot-value object slot-name) default)) - -(defun standard-instance-access (instance location) - (clos-slots-ref (std-instance-slots instance) location)) - -(defun funcallable-standard-instance-access (instance location) - (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value @@ -197,6 +255,8 @@ (new-value (class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; 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 @@ -226,6 +286,8 @@ ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value @@ -305,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))) @@ -380,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. @@ -392,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)))))