Permalink
Browse files

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 :-/
  • Loading branch information...
csrhodes committed Jun 17, 2003
1 parent 3cf5c83 commit 937a46e64983862cb9e21761db95e58700341940
Showing with 68 additions and 81 deletions.
  1. +3 −0 NEWS
  2. +44 −38 src/pcl/slots-boot.lisp
  3. +16 −40 src/pcl/slots.lisp
  4. +1 −1 src/pcl/std-class.lisp
  5. +3 −1 tests/clos.impure.lisp
  6. +1 −1 version.lisp-expr
View
3 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
View
@@ -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,22 +307,22 @@
(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))
(check-obsolete-instance instance)
(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 "~@<The wrapper for class ~S does not have ~
View
@@ -75,34 +75,6 @@
(t
(error "unrecognized instance type")))))
-(defun get-class-slot-value-1 (object wrapper slot-name)
- (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
- (if (null entry)
- (slot-missing (wrapper-class wrapper) object slot-name 'slot-value)
- (if (eq (cdr entry) +slot-unbound+)
- (slot-unbound (wrapper-class wrapper) object slot-name)
- (cdr entry)))))
-
-(defun set-class-slot-value-1 (new-value object wrapper slot-name)
- (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
- (if (null entry)
- (slot-missing (wrapper-class wrapper)
- object
- slot-name
- 'setf
- new-value)
- (setf (cdr entry) new-value))))
-
-(defmethod class-slot-value ((class std-class) slot-name)
- (let ((wrapper (class-wrapper class))
- (prototype (class-prototype class)))
- (get-class-slot-value-1 prototype wrapper slot-name)))
-
-(defmethod (setf class-slot-value) (nv (class std-class) slot-name)
- (let ((wrapper (class-wrapper class))
- (prototype (class-prototype class)))
- (set-class-slot-value-1 nv prototype wrapper slot-name)))
-
(defun find-slot-definition (class slot-name)
(dolist (slot (class-slots class) nil)
(when (eql slot-name (slot-definition-name slot))
@@ -112,7 +84,7 @@
(let* ((class (class-of object))
(slot-definition (find-slot-definition class slot-name)))
(if (null slot-definition)
- (slot-missing class object slot-name 'slot-value)
+ (values (slot-missing class object slot-name 'slot-value))
(slot-value-using-class class object slot-definition))))
(define-compiler-macro slot-value (&whole form object slot-name)
@@ -125,7 +97,8 @@
(let* ((class (class-of object))
(slot-definition (find-slot-definition class slot-name)))
(if (null slot-definition)
- (slot-missing class object slot-name 'setf new-value)
+ (progn (slot-missing class object slot-name 'setf new-value)
+ new-value)
(setf (slot-value-using-class class object slot-definition)
new-value))))
@@ -139,7 +112,7 @@
(let* ((class (class-of object))
(slot-definition (find-slot-definition class slot-name)))
(if (null slot-definition)
- (slot-missing class object slot-name 'slot-boundp)
+ (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)
@@ -155,7 +128,8 @@
(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))))
+ (slot-makunbound-using-class class object slot-definition))
+ object))
(defun slot-exists-p (object slot-name)
(let ((class (class-of object)))
@@ -196,7 +170,7 @@
~S method.~@:>"
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))
View
@@ -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)))
View
@@ -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 () ())
View
@@ -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"

0 comments on commit 937a46e

Please sign in to comment.