From 4faa083cde7b2974251fffd00a0765430927689c Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Sun, 15 Jun 2003 14:06:26 +0000
Subject: [PATCH] 	SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP,
 SLOT-MAKUNBOUND not 	returning values specified by the standard when 
 SLOT-MISSING/SLOT-UNBOUND are called and return.  Found by Paul 	Dietz.

	* src/pcl/std-class.lisp (compute-effective-slot-definition):
	Return slot-unbound's primary value.

	* src/pcl/slots.lisp (slot-value): Return slot-missing's primary
	value.
	(set-slot-value): Always return the new value.
	(slot-boundp): Return a boolean equivalent of slot-missing's
	primary value.
	(slot-makunbound): Always return the instance.
	(slot-value-using-class): Return slot-unbound's primary value.
	(slot-unbound-internal): Likewise.

	* src/pcl/slots-boot.lisp (ensure-accessor): Return slot-missing's
	primary value for slot-value, a boolean equivalent of its primary
	value for slot-boundp, and always return the value for setf.
	(accessor-set-slot-value): Always return the new value.
	(make-optimized-std-reader-method-function): Return slot-unbound's
	primary value.
	(make-optimized-std-slot-value-using-class-method-function)
	(make-internal-reader-method-function): Likewise.

	* src/pcl/method-slot-access-optimization.lisp
	(inline-slot-unbound): Return slot-unbound's primary value.
---
 general-info/release-19a.txt             |  3 ++
 pcl/method-slot-access-optimization.lisp |  4 +--
 pcl/slots-boot.lisp                      | 37 +++++++++++++-----------
 pcl/slots.lisp                           | 29 ++++++++++---------
 pcl/std-class.lisp                       |  4 +--
 5 files changed, 43 insertions(+), 34 deletions(-)

diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index 0258e2e22..1560a6227 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -117,6 +117,9 @@ New in this release:
      - DEFCLASS redefining a class with the given name only if the
        name is the proper name of an existing class.
      - KEYWORD package no longer having nickname "".
+     - SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
+       returning values specified by the standard when SLOT-UNBOUND
+       or SLOT-MISSING are called and return.
 
   * Numerous bugfixes:
      - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR
diff --git a/pcl/method-slot-access-optimization.lisp b/pcl/method-slot-access-optimization.lisp
index 2a5343114..564669c67 100644
--- a/pcl/method-slot-access-optimization.lisp
+++ b/pcl/method-slot-access-optimization.lisp
@@ -52,7 +52,7 @@
 ;;;
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/method-slot-access-optimization.lisp,v 1.4 2003/05/08 11:21:33 gerd Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/method-slot-access-optimization.lisp,v 1.5 2003/06/15 14:06:26 gerd Exp $")
  
 (in-package "PCL")
 
@@ -364,7 +364,7 @@
 	`(the ,slot-type ,read-form))))
 
 (defun inline-slot-unbound (instance slot-name)
-  (slot-unbound (class-of instance) instance slot-name))
+  (values (slot-unbound (class-of instance) instance slot-name)))
 
 (defmacro inline-slot-boundp (class slot-name slots-variable)
   (multiple-value-bind (read-form slot-type)
diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp
index 773acd5c1..8da01df70 100644
--- a/pcl/slots-boot.lisp
+++ b/pcl/slots-boot.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.23 2003/05/11 11:30:34 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.24 2003/06/15 14:06:26 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -51,19 +51,19 @@
 		       (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)))))
 		    (initargs (copy-tree initargs)))
 	       (setf (getf (getf initargs :plist) :slot-name-lists)
 		     (list (list nil slot-name)))
@@ -127,9 +127,12 @@
 			 (setq object object-var)))))
 	 (writer-name (slot-writer-name slot-name))
 	 (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)))
@@ -182,19 +185,19 @@
 		   (check-obsolete-instance instance)
 		   (let ((value (%slot-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 (%slot-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)
 	       (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)))
 
@@ -304,21 +307,21 @@
 		  (check-obsolete-instance instance)
 		  (let ((value (%slot-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 (%slot-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
@@ -374,12 +377,12 @@
 		      (fixnum 	
 		       (let ((value (%slot-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 ~
diff --git a/pcl/slots.lisp b/pcl/slots.lisp
index 4cb2fbfc0..f51d302bf 100644
--- a/pcl/slots.lisp
+++ b/pcl/slots.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.25 2003/06/12 09:06:30 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots.lisp,v 1.26 2003/06/15 14:06:26 gerd Exp $")
 ;;;
 
 (in-package :pcl)
@@ -87,7 +87,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))))
 
 (defun set-slot-value (object slot-name new-value)
@@ -96,7 +96,8 @@
     (if (null slot-definition)
 	(slot-missing class object slot-name 'setf new-value)
 	(setf (slot-value-using-class class object slot-definition) 
-	      new-value))))
+	      new-value))
+    new-value))
 
 (define-compiler-macro slot-value (&whole form object slot-name)
   (if (and (constantp slot-name)
@@ -114,7 +115,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))))
 
 (define-compiler-macro slot-boundp (&whole form object slot-name)
@@ -128,7 +129,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)))
@@ -173,7 +175,7 @@
                            method.~@:>"
 			  slotd :instance :class '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)
@@ -316,13 +318,14 @@
   (error 'unbound-slot :name slot-name :slot 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 &key)
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 71e6a93e4..d8dd2dc3f 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.69 2003/06/10 09:20:43 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.70 2003/06/15 14:06:26 gerd Exp $")
 
 (in-package :pcl)
 
@@ -1644,7 +1644,7 @@
 	  (lambda (x)
 	    (handler-case 
 		(conditions::condition-reader-function x slot-name)
-	      (error () (slot-unbound class x slot-name)))))
+	      (error () (values (slot-unbound class x slot-name))))))
     (setf (slot-definition-writer-function slotd)
 	  (lambda (v x)
 	    (conditions::condition-writer-function x v slot-name)))
-- 
GitLab