X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=43bf09ae619e5a43a4032d662152a11914714b64;hb=c8cc0137e55e6179f6af344f42e54f514660f68b;hp=6bd1e8b1b34d96bd70e561f38a8e8145c9e4e29e;hpb=83e5661ae59addac315e6754013b3887b477570f;p=sbcl.git

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 6bd1e8b..43bf09a 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)
@@ -76,8 +78,12 @@
                                              (slot-missing-fun slot-name type)
                                              "generated slot-missing method"
                                              slot-name)))))
-        (unless (fboundp fun-name)
-      (let ((gf (ensure-generic-function fun-name)))
+    (unless (fboundp fun-name)
+      (let ((gf (ensure-generic-function
+		 fun-name
+		 :lambda-list (ecase type
+				((reader boundp) '(object))
+				(writer '(new-value object))))))
         (ecase type
           (reader (add-slot-missing-method gf slot-name 'slot-value))
           (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
@@ -92,7 +98,8 @@
     `(let ((.ignore. (load-time-value
 		      (ensure-accessor 'reader ',reader-name ',slot-name))))
       (declare (ignore .ignore.))
-      (funcall #',reader-name ,object))))
+      (truly-the (values t &optional)
+                 (funcall #',reader-name ,object)))))
 
 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
   (aver (constantp slot-name))
@@ -107,9 +114,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 +174,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 +312,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 +320,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 +400,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 ~
@@ -458,15 +469,16 @@
 	   initargs)))
 
 (defun initialize-internal-slot-gfs (slot-name &optional type)
-  (macrolet ((frob (type name-fun add-fun)
+  (macrolet ((frob (type name-fun add-fun ll)
 	       `(when (or (null type) (eq type ',type))
 		 (let* ((name (,name-fun slot-name))
-			(gf (ensure-generic-function name))
+			(gf (ensure-generic-function name
+						     :lambda-list ',ll))
 			(methods (generic-function-methods gf)))
 		   (when (or (null methods)
 			     (plist-value gf 'slot-missing-method))
 		     (setf (plist-value gf 'slot-missing-method) nil)
 		     (,add-fun *the-class-slot-object* gf slot-name))))))
-    (frob reader slot-reader-name add-reader-method)
-    (frob writer slot-writer-name add-writer-method)
-    (frob boundp slot-boundp-name add-boundp-method)))
+    (frob reader slot-reader-name add-reader-method (object))
+    (frob writer slot-writer-name add-writer-method (new-value object))
+    (frob boundp slot-boundp-name add-boundp-method (object))))