From 937a46e64983862cb9e21761db95e58700341940 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 17 Jun 2003 12:14:59 +0000 Subject: [PATCH] 0.8.0.78: Fix SLOT-MISSING/SLOT-UNBOUND bugs found by Paul Dietz' test suite ... return a single value for SLOT-VALUE, the new value for (SETF SLOT-VALUE), a boolean equivalent for SLOT-BOUNDP and the object for SLOT-MAKUNBOUND ` ... adjust a bogus test in our regression test suite :-/ --- NEWS | 3 ++ src/pcl/slots-boot.lisp | 82 +++++++++++++++++++++++++---------------------- src/pcl/slots.lisp | 56 +++++++++----------------------- src/pcl/std-class.lisp | 2 +- tests/clos.impure.lisp | 4 ++- version.lisp-expr | 2 +- 6 files changed, 68 insertions(+), 81 deletions(-) diff --git a/NEWS b/NEWS index d349adc..e4f3f18 100644 --- a/NEWS +++ b/NEWS @@ -1874,6 +1874,9 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: ** SLOT-UNBOUND now correctly initalizes the CELL-ERROR-NAME slot of the UNBOUND-SLOT condition to the name of the slot. ** (SETF (AREF bv 0) ...) did not work for bit vectors. + ** SLOT-UNBOUND and SLOT-MISSING now have their return values + treated by SLOT-BOUNDP, SLOT-VALUE, (SETF SLOT-VALUE) and + SLOT-MAKUNBOUND in the specified fashion. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 6bd1e8b..dc46d56 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -35,19 +35,21 @@ (slot-value (make-method-function (lambda (obj) - (slot-missing (class-of obj) obj slot-name - 'slot-value)))) + (values + (slot-missing (class-of obj) obj slot-name + 'slot-value))))) (slot-boundp (make-method-function (lambda (obj) - (slot-missing (class-of obj) obj slot-name - 'slot-boundp)))) + (not (not + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))))) (setf (make-method-function (lambda (val obj) - (declare (ignore val)) (slot-missing (class-of obj) obj slot-name - 'setf)))))))) + 'setf val) + val))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) @@ -107,9 +109,11 @@ (form `(let ((.ignore. (load-time-value - (ensure-accessor 'writer ',writer-name ',slot-name)))) + (ensure-accessor 'writer ',writer-name ',slot-name))) + (.new-value. ,new-value)) (declare (ignore .ignore.)) - (funcall #',writer-name ,new-value ,object)))) + (funcall #',writer-name .new-value. ,object) + .new-value.))) (if bindings `(let ,bindings ,form) form))) @@ -165,27 +169,29 @@ (declare #.*optimize-speed*) (set-fun-name (etypecase index - (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))) - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))))) - (cons (lambda (instance) - (check-obsolete-instance instance) - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))))) + (fixnum + (if fsc-p + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) index))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))))) + (cons + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (cdr index))) + (if (eq value +slot-unbound+) + (values (slot-unbound (class-of instance) instance slot-name)) + value))))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function (fsc-p slot-name index) @@ -301,7 +307,7 @@ (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value))) (lambda (class instance slotd) (declare (ignore slotd)) @@ -309,14 +315,14 @@ (let ((value (clos-slots-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value))))) (cons (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) (let ((value (cdr index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function @@ -389,16 +395,16 @@ (let ((value (clos-slots-ref (get-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) - instance - slot-name) + (values (slot-unbound (class-of instance) + instance + slot-name)) value))) (cons (let ((value (cdr index))) (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) - instance - slot-name) + (values (slot-unbound (class-of instance) + instance + slot-name)) value))) (t (error "~@" slotd 'slot-value-using-class))))) (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) + (values (slot-unbound class object (slot-definition-name slotd))) value))) (defmethod (setf slot-value-using-class) @@ -346,13 +320,15 @@ (error 'unbound-slot :name slot-name :instance instance)) (defun slot-unbound-internal (instance position) - (slot-unbound (class-of instance) instance - (etypecase position - (fixnum - (nth position - (wrapper-instance-slots-layout (wrapper-of instance)))) - (cons - (car position))))) + (values + (slot-unbound + (class-of instance) + instance + (etypecase position + (fixnum + (nth position (wrapper-instance-slots-layout (wrapper-of instance)))) + (cons + (car position)))))) (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 50fd53a..f894c21 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -661,7 +661,7 @@ ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot ;; is unbound; maybe it should be a CELL-ERROR of some ;; sort? - (error () (slot-unbound class x slot-name))))) + (error () (values (slot-unbound class x slot-name)))))) (setf (slot-definition-writer-function slotd) (lambda (v x) (condition-writer-function x v slot-name))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index a94d842..a319f42 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -592,7 +592,9 @@ 'slot-value)) (assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz)) (make-instance 'class-with-all-slots-missing)) - 'setf)) + ;; SLOT-MISSING's value is specified to be ignored; we + ;; return NEW-VALUE. + 'baz)) ;;; we should be able to specialize on anything that names a class. (defclass name-for-class () ()) diff --git a/version.lisp-expr b/version.lisp-expr index bdb6f26..02363f9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.77" +"0.8.0.78" -- 1.7.10.4