X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=dc7b804b294a492e513c314fa0e931a0a2591106;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=274d682def0b21dfaf7779835bed7744193e8048;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 274d682..dc7b804 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)))
@@ -129,103 +138,160 @@
     (declare (ignore object))
     t))
 
+(define-condition instance-structure-protocol-error
+    (reference-condition error)
+  ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
+   (fun :initarg :fun :reader instance-structure-protocol-error-fun))
+  (:report
+   (lambda (c s)
+     (format s "~@<The slot ~S has neither ~S nor ~S ~
+                allocation, so it can't be ~A by the default ~
+                ~S method.~@:>"
+	     (instance-structure-protocol-error-slotd c)
+	     :instance :class
+	     (cond
+	       ((member (instance-structure-protocol-error-fun c)
+			'(slot-value-using-class slot-boundp-using-class))
+		"read")
+	       (t "written"))
+	     (instance-structure-protocol-error-fun c)))))
+
+(defun instance-structure-protocol-error (slotd fun)
+  (error 'instance-structure-protocol-error
+	 :slotd slotd :fun fun
+	 :references (list `(:amop :generic-function ,fun)
+			   '(:amop :section (5 5 3)))))
+
 (defun get-optimized-std-accessor-method-function (class slotd name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (slot-definition-internal-reader-function slotd))
-	(writer (slot-definition-internal-writer-function slotd))
-	(boundp (make-structure-slot-boundp-function slotd)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  ((std-class-p class)
-			   ;; Shouldn't be using the optimized-std-accessors
-			   ;; in this case.
-			   #+nil (format t "* warning: ~S ~S~%   ~S~%"
-				   name slotd class)
-			   nil)
-			  (t (error "~S is not a STANDARD-CLASS." class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function (ecase name
-			 (reader #'make-optimized-std-reader-method-function)
-			 (writer #'make-optimized-std-writer-method-function)
-			 (boundp #'make-optimized-std-boundp-method-function)))
-	     (value (funcall function fsc-p slot-name index)))
-	(declare (type function function))
-	(values value index))))
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (slot-definition-internal-reader-function slotd))
+       (writer (slot-definition-internal-writer-function slotd))
+       (boundp (make-structure-slot-boundp-function slotd))))
+    ((condition-class-p class)
+     (ecase name
+       (reader (slot-definition-reader-function slotd))
+       (writer (slot-definition-writer-function slotd))
+       (boundp (slot-definition-boundp-function slotd))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+			 ((funcallable-standard-class-p class) t)
+			 ((std-class-p class)
+			  ;; Shouldn't be using the optimized-std-accessors
+			  ;; in this case.
+			  #+nil (format t "* warning: ~S ~S~%   ~S~%"
+					name slotd class)
+			  nil)
+			 (t (error "~S is not a STANDARD-CLASS." class))))
+	    (slot-name (slot-definition-name slotd))
+	    (location (slot-definition-location slotd))
+	    (function (ecase name
+			(reader #'make-optimized-std-reader-method-function)
+			(writer #'make-optimized-std-writer-method-function)
+			(boundp #'make-optimized-std-boundp-method-function)))
+	    ;; KLUDGE: we need this slightly hacky calling convention
+	    ;; for these functions for bootstrapping reasons: see
+	    ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
+	    ;; 2004-07-12
+	    (value (funcall function fsc-p slotd slot-name location)))
+       (declare (type function function))
+       (values value (slot-definition-location slotd))))))
 
-(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
+(defun make-optimized-std-reader-method-function
+    (fsc-p slotd slot-name location)
   (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)))))
+   (etypecase location
+     (fixnum
+      (if fsc-p
+	  (lambda (instance)
+	    (check-obsolete-instance instance)
+	    (let ((value (clos-slots-ref (fsc-instance-slots instance)
+					 location)))
+	      (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)
+					 location)))
+	      (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 location)))
+	  (if (eq value +slot-unbound+)
+	      (values (slot-unbound (class-of instance) instance slot-name))
+	      value))))
+     (null
+      (lambda (instance)
+	(instance-structure-protocol-error slotd 'slot-value-using-class))))
    `(reader ,slot-name)))
 
-(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
+(defun make-optimized-std-writer-method-function
+    (fsc-p slotd slot-name location)
   (declare #.*optimize-speed*)
   (set-fun-name
-   (etypecase index
+   (etypecase location
      (fixnum (if fsc-p
 		 (lambda (nv instance)
 		   (check-obsolete-instance instance)
-		   (setf (clos-slots-ref (fsc-instance-slots instance) index)
+		   (setf (clos-slots-ref (fsc-instance-slots instance)
+					 location)
 			 nv))
 		 (lambda (nv instance)
 		   (check-obsolete-instance instance)
-		   (setf (clos-slots-ref (std-instance-slots instance) index)
+		   (setf (clos-slots-ref (std-instance-slots instance)
+					 location)
 			 nv))))
-     (cons   (lambda (nv instance)
-	       (check-obsolete-instance instance)
-	       (setf (cdr index) nv))))
+     (cons (lambda (nv instance)
+	     (check-obsolete-instance instance)
+	     (setf (cdr location) nv)))
+     (null
+      (lambda (nv instance)
+	(declare (ignore nv))
+	(instance-structure-protocol-error slotd
+					   '(setf slot-value-using-class)))))
    `(writer ,slot-name)))
 
-(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+(defun make-optimized-std-boundp-method-function
+    (fsc-p slotd slot-name location)
   (declare #.*optimize-speed*)
   (set-fun-name
-   (etypecase index
+   (etypecase location
      (fixnum (if fsc-p
 		 (lambda (instance)
 		   (check-obsolete-instance instance)
 		   (not (eq (clos-slots-ref (fsc-instance-slots instance)
-					    index)
+					    location)
 			    +slot-unbound+)))
 		 (lambda (instance)
 		   (check-obsolete-instance instance)
 		   (not (eq (clos-slots-ref (std-instance-slots instance)
-					    index)
+					    location)
 			    +slot-unbound+)))))
      (cons (lambda (instance)
 	     (check-obsolete-instance instance)
-	     (not (eq (cdr index) +slot-unbound+)))))
+	     (not (eq (cdr location) +slot-unbound+))))
+     (null
+      (lambda (instance)
+	(instance-structure-protocol-error slotd 'slot-boundp-using-class))))
    `(boundp ,slot-name)))
 
-(defun make-optimized-structure-slot-value-using-class-method-function (function)
+(defun make-optimized-structure-slot-value-using-class-method-function
+    (function)
   (declare (type function function))
   (lambda (class object slotd)
     (declare (ignore class slotd))
     (funcall function object)))
 
-(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
+(defun make-optimized-structure-setf-slot-value-using-class-method-function
+    (function)
   (declare (type function function))
   (lambda (nv class object slotd)
     (declare (ignore class slotd))
@@ -236,102 +302,138 @@
     (declare (ignore class object slotd))
     t))
 
-(defun get-optimized-std-slot-value-using-class-method-function (class
-								 slotd
-								 name)
-  (if (structure-class-p class)
-      (ecase name
-	(reader (make-optimized-structure-slot-value-using-class-method-function
-		 (slot-definition-internal-reader-function slotd)))
-	(writer (make-optimized-structure-setf-slot-value-using-class-method-function
-		 (slot-definition-internal-writer-function slotd)))
-	(boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
-      (let* ((fsc-p (cond ((standard-class-p class) nil)
-			  ((funcallable-standard-class-p class) t)
-			  (t (error "~S is not a standard-class" class))))
-	     (slot-name (slot-definition-name slotd))
-	     (index (slot-definition-location slotd))
-	     (function
-	      (ecase name
-		(reader
-		 #'make-optimized-std-slot-value-using-class-method-function)
-		(writer
-		 #'make-optimized-std-setf-slot-value-using-class-method-function)
-		(boundp
-		 #'make-optimized-std-slot-boundp-using-class-method-function))))
-	(declare (type function function))
-	(values (funcall function fsc-p slot-name index) index))))
+(defun get-optimized-std-slot-value-using-class-method-function
+    (class slotd name)
+  (cond
+    ((structure-class-p class)
+     (ecase name
+       (reader (make-optimized-structure-slot-value-using-class-method-function
+		(slot-definition-internal-reader-function slotd)))
+       (writer (make-optimized-structure-setf-slot-value-using-class-method-function
+		(slot-definition-internal-writer-function slotd)))
+       (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
+    ((condition-class-p class)
+     (ecase name
+       (reader
+	(let ((fun (slot-definition-reader-function slotd)))
+	  (declare (type function fun))
+	  (lambda (class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun object))))
+       (writer
+	(let ((fun (slot-definition-writer-function slotd)))
+	  (declare (type function fun))
+	  (lambda (new-value class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun new-value object))))
+       (boundp
+	(let ((fun (slot-definition-boundp-function slotd)))
+	  (declare (type function fun))
+	  (lambda (class object slotd)
+	    (declare (ignore class slotd))
+	    (funcall fun object))))))
+    (t
+     (let* ((fsc-p (cond ((standard-class-p class) nil)
+			 ((funcallable-standard-class-p class) t)
+			 (t (error "~S is not a standard-class" class))))
+	    (function
+	     (ecase name
+	       (reader
+		#'make-optimized-std-slot-value-using-class-method-function)
+	       (writer
+		#'make-optimized-std-setf-slot-value-using-class-method-function)
+	       (boundp
+		#'make-optimized-std-slot-boundp-using-class-method-function))))
+       (declare (type function function))
+       (values (funcall function fsc-p slotd)
+	       (slot-definition-location slotd))))))
 
-(defun make-optimized-std-slot-value-using-class-method-function
-    (fsc-p slot-name index)
+(defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
   (declare #.*optimize-speed*)
-  (etypecase index
-    (fixnum (if fsc-p
-		(lambda (class instance slotd)
-		  (declare (ignore slotd))
-		  (check-obsolete-instance instance)
-		  (let ((value (clos-slots-ref (fsc-instance-slots instance)
-					       index)))
-		    (if (eq value +slot-unbound+)
-			(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)
-			value)))))
-    (cons   (lambda (class instance slotd)
+  (let ((location (slot-definition-location slotd))
+	(slot-name (slot-definition-name slotd)))
+    (etypecase location
+      (fixnum (if fsc-p
+		  (lambda (class instance slotd)
+		    (declare (ignore slotd))
+		    (check-obsolete-instance instance)
+		    (let ((value (clos-slots-ref (fsc-instance-slots instance)
+						 location)))
+		      (if (eq value +slot-unbound+)
+			  (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)
+						 location)))
+		      (if (eq value +slot-unbound+)
+			  (values (slot-unbound class instance slot-name))
+			  value)))))
+      (cons (lambda (class instance slotd)
 	      (declare (ignore slotd))
 	      (check-obsolete-instance instance)
-	      (let ((value (cdr index)))
+	      (let ((value (cdr location)))
 		(if (eq value +slot-unbound+)
-		    (slot-unbound class instance slot-name)
-		    value))))))
+		    (values (slot-unbound class instance slot-name))
+		    value))))
+      (null
+       (lambda (class instance slotd)
+	 (declare (ignore class instance))
+	 (instance-structure-protocol-error slotd 'slot-value-using-class))))))
 
 (defun make-optimized-std-setf-slot-value-using-class-method-function
-    (fsc-p slot-name index)
+    (fsc-p slotd)
   (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		(lambda (nv class instance slotd)
-		  (declare (ignore class slotd))
-		  (check-obsolete-instance instance)
-		  (setf (clos-slots-ref (fsc-instance-slots instance) index)
-			nv))
-		(lambda (nv class instance slotd)
-		  (declare (ignore class slotd))
-		  (check-obsolete-instance instance)
-		  (setf (clos-slots-ref (std-instance-slots instance) index)
-			nv))))
-    (cons  (lambda (nv class instance slotd)
+  (let ((location (slot-definition-location slotd)))
+    (etypecase location
+      (fixnum
+       (if fsc-p
+	   (lambda (nv class instance slotd)
 	     (declare (ignore class slotd))
 	     (check-obsolete-instance instance)
-	     (setf (cdr index) nv)))))
+	     (setf (clos-slots-ref (fsc-instance-slots instance) location)
+		   nv))
+	   (lambda (nv class instance slotd)
+	     (declare (ignore class slotd))
+	     (check-obsolete-instance instance)
+	     (setf (clos-slots-ref (std-instance-slots instance) location)
+		   nv))))
+      (cons (lambda (nv class instance slotd)
+	      (declare (ignore class slotd))
+	      (check-obsolete-instance instance)
+	      (setf (cdr location) nv)))
+      (null (lambda (nv class instance slotd)
+	      (declare (ignore nv class instance))
+	      (instance-structure-protocol-error
+	       slotd '(setf slot-value-using-class)))))))
 
 (defun make-optimized-std-slot-boundp-using-class-method-function
-    (fsc-p slot-name index)
+    (fsc-p slotd)
   (declare #.*optimize-speed*)
-  (declare (ignore slot-name))
-  (etypecase index
-    (fixnum (if fsc-p
-		(lambda (class instance slotd)
-		  (declare (ignore class slotd))
-		  (check-obsolete-instance instance)
-		  (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
-			   +slot-unbound+)))
-		(lambda (class instance slotd)
-		  (declare (ignore class slotd))
-		  (check-obsolete-instance instance)
-		  (not (eq (clos-slots-ref (std-instance-slots instance) index)
-			   +slot-unbound+)))))
-    (cons   (lambda (class instance slotd)
+  (let ((location (slot-definition-location slotd)))
+    (etypecase location
+      (fixnum
+       (if fsc-p
+	   (lambda (class instance slotd)
+	     (declare (ignore class slotd))
+	     (check-obsolete-instance instance)
+	     (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
+		      +slot-unbound+)))
+	   (lambda (class instance slotd)
+	     (declare (ignore class slotd))
+	     (check-obsolete-instance instance)
+	     (not (eq (clos-slots-ref (std-instance-slots instance) location)
+		      +slot-unbound+)))))
+      (cons (lambda (class instance slotd)
 	      (declare (ignore class slotd))
 	      (check-obsolete-instance instance)
-	      (not (eq (cdr index) +slot-unbound+))))))
+	      (not (eq (cdr location) +slot-unbound+))))
+      (null
+       (lambda (class instance slotd)
+	 (declare (ignore class instance))
+	 (instance-structure-protocol-error slotd
+					    'slot-boundp-using-class))))))
 
 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
   (macrolet ((emf-funcall (emf &rest args)
@@ -361,16 +463,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 ~
@@ -430,15 +532,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))))