Commit 937a46e6 authored by Christophe Rhodes's avatar Christophe Rhodes
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 :-/
parent 3cf5c835
Loading
Loading
Loading
Loading
+3 −0
Original line number Diff line number Diff line
@@ -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
+44 −38
Original line number Diff line number Diff line
@@ -35,19 +35,21 @@
			(slot-value
			 (make-method-function
			  (lambda (obj)
			    (values
			     (slot-missing (class-of obj) obj slot-name
					  'slot-value))))
					   'slot-value)))))
			(slot-boundp
			 (make-method-function
			  (lambda (obj)
			    (not (not
				  (slot-missing (class-of obj) obj slot-name
					  'slot-boundp))))
						'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,26 +169,28 @@
  (declare #.*optimize-speed*)
  (set-fun-name
   (etypecase index
     (fixnum (if fsc-p
     (fixnum
      (if fsc-p
	  (lambda (instance)
	    (check-obsolete-instance instance)
		   (let ((value (clos-slots-ref (fsc-instance-slots instance)
						index)))
	    (let ((value (clos-slots-ref (fsc-instance-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)))
	  (lambda (instance)
	    (check-obsolete-instance instance)
		   (let ((value (clos-slots-ref (std-instance-slots instance)
					      index)))
	    (let ((value (clos-slots-ref (std-instance-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   (lambda (instance)
     (cons
      (lambda (instance)
	(check-obsolete-instance instance)
	(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)))))
   `(reader ,slot-name)))

@@ -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)
			     (values (slot-unbound (class-of instance)
						   instance
					   slot-name)
						   slot-name))
			     value)))
		      (cons
		       (let ((value (cdr index)))
			 (if (eq value +slot-unbound+)
			     (slot-unbound (class-of instance)
			     (values (slot-unbound (class-of instance)
						   instance
					   slot-name)
						   slot-name))
			     value)))
		      (t
		       (error "~@<The wrapper for class ~S does not have ~
+16 −40
Original line number Diff line number Diff line
@@ -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
  (values
   (slot-unbound
    (class-of instance)
    instance
    (etypecase position
      (fixnum
		   (nth position
			(wrapper-instance-slots-layout (wrapper-of instance))))
       (nth position (wrapper-instance-slots-layout (wrapper-of instance))))
      (cons
		   (car position)))))
       (car position))))))

(defmethod allocate-instance ((class standard-class) &rest initargs)
  (declare (ignore initargs))
+1 −1
Original line number Diff line number Diff line
@@ -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)))
+3 −1
Original line number Diff line number Diff line
@@ -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 () ())
Loading