X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=2ae32b07a8f958ee362ec6d73841df1d65e4d96b;hb=41791073db3aa668ad5699598edcb567d4eed966;hp=4ca54159efe6a5d299b8beb41ce08808c1ac4b6f;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 4ca5415..2ae32b0 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -28,9 +28,19 @@ (define-condition unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance)) (:report (lambda (condition stream) - (format stream "The slot ~S is unbound in the object ~S." - (cell-error-name condition) - (unbound-slot-instance condition))))) + (handler-case + (format stream "~@" + (cell-error-name condition) + (unbound-slot-instance condition)) + (serious-condition () + ;; In case of an error try again avoiding custom PRINT-OBJECT's. + (format stream "~&Error during printing.~%~@" + (cell-error-name condition) + (type-of (unbound-slot-instance condition)))))))) (defmethod wrapper-fetcher ((class standard-class)) 'std-instance-wrapper) @@ -68,9 +78,12 @@ ;;;; STANDARD-INSTANCE-ACCESS -(declaim (inline standard-instance-access (setf standard-instance-access) +(declaim (inline standard-instance-access + (setf standard-instance-access) + (cas stadard-instance-access) funcallable-standard-instance-access - (setf funcallable-standard-instance-access))) + (setf funcallable-standard-instance-access) + (cas funcallable-standard-instance-access))) (defun standard-instance-access (instance location) (clos-slots-ref (std-instance-slots instance) location)) @@ -78,18 +91,29 @@ (defun (setf standard-instance-access) (new-value instance location) (setf (clos-slots-ref (std-instance-slots instance) location) new-value)) +(defun (cas standard-instance-access) (old-value new-value instance location) + ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? + (cas (svref (std-instance-slots instance) location) old-value new-value)) + (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 (cas funcallable-standard-instance-access) (old-value new-value instance location) + ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? + (cas (svref (fsc-instance-slots instance) location) old-value new-value)) ;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) (let* ((wrapper (valid-wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (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) @@ -98,19 +122,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) @@ -120,11 +142,15 @@ (defun set-slot-value (object slot-name new-value) (let* ((wrapper (valid-wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (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) @@ -132,11 +158,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) @@ -148,6 +171,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) @@ -161,9 +186,41 @@ `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) +(defun (cas slot-value) (old-value new-value object 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 + 'cas (list old-value new-value)))))) + (location (car cell)) + (info (cdr cell)) + (typecheck (slot-info-typecheck info))) + (when typecheck + (funcall typecheck new-value)) + (let ((old (cond ((fixnump location) + (if (std-instance-p object) + (cas (standard-instance-access object location) old-value new-value) + (cas (funcallable-standard-instance-access object location) + old-value new-value))) + ((consp location) + (cas (cdr location) old-value new-value)) + ((not location) + ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)... + (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object)) + (t + (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell))))) + (if (and (eq +slot-unbound+ old) + (neq old old-value)) + (slot-unbound (wrapper-class* wrapper) object slot-name) + old)))) + (defun slot-boundp (object slot-name) (let* ((wrapper (valid-wrapper-of object)) - (cell (find-slot-cell wrapper slot-name)) + (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) @@ -172,14 +229,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)))) @@ -205,7 +257,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) @@ -258,29 +311,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) @@ -335,8 +386,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) @@ -344,16 +394,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) @@ -426,13 +474,21 @@ instance (etypecase position (fixnum - (nth position (wrapper-instance-slots-layout (wrapper-of instance)))) + ;; In the vast majority of cases location corresponds to the position + ;; in list. The only exceptions are when there are non-local slots + ;; before the one we want. + (let* ((slots (wrapper-slots (wrapper-of instance))) + (guess (nth position slots))) + (if (eql position (slot-definition-location guess)) + (slot-definition-name guess) + (slot-definition-name + (car (member position (class-slots instance) :key #'slot-definition-location)))))) (cons (car position)))))) ;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance ;;; if the class is not yet finalized, but we don't seem to be taking -;;; care of this for non-standard-classes.x +;;; care of this for non-standard-classes. (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) (unless (class-finalized-p class) @@ -444,13 +500,11 @@ (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. (defmethod allocate-instance ((class condition-class) &rest initargs) (declare (ignore initargs)) - (make-condition (class-name class))) + (allocate-condition (class-name class))) (defmethod allocate-instance ((class built-in-class) &rest initargs) (declare (ignore initargs))