[Sbcl-commits] CVS: sbcl/src/pcl methods.lisp,1.22,1.23 std-class.lisp,1.45,1.46

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1:/tmp/cvs-serv7363/src/pcl

Modified Files:
	methods.lisp std-class.lisp 
Log Message:
0.pre8.115:
	Fix for SLOT-VALUE inside (SETF SLOT-VALUE-USING-CLASS), from 
	Gerd Moellmann (test case a simplified version of KMR's 
	hyperobject)
	... don't pass a NIL wrapper to the relevant PCL functions
	... one or two code cleanups and comments


Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- methods.lisp	25 Mar 2003 16:31:01 -0000	1.22
+++ methods.lisp	28 Apr 2003 11:00:29 -0000	1.23
@@ -758,6 +758,22 @@
 			   *standard-method-combination*))
 	      type)))))
 
+
+;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
+;;;
+;;; Return two values.  First value is a function to be stored in
+;;; effective slot definition SLOTD for reading it with
+;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
+;;; SLOT-VALUE-USING-CLASS) or testing it with
+;;; SLOT-BOUNDP-USING-CLASS.  GF is one of these generic functions,
+;;; TYPE is one of the symbols READER, WRITER, BOUNDP.  CLASS is
+;;; SLOTD's class.
+;;;
+;;; Second value is true if the function returned is one of the
+;;; optimized standard functions for the purpose, which are used
+;;; when only standard methods are applicable.
+;;;
+;;; FIXME: Change all these wacky function names to something sane.
 (defun get-accessor-method-function (gf type class slotd)
   (let* ((std-method (standard-svuc-method type))
 	 (str-method (structure-svuc-method type))
@@ -768,27 +784,25 @@
     (values
      (if std-p
 	 (get-optimized-std-accessor-method-function class slotd type)
-	 (get-accessor-from-svuc-method-function
-	  class slotd
-	  (get-secondary-dispatch-function
-	   gf methods types
-	   `((,(car (or (member std-method methods)
-			(member str-method methods)
-			(error "error in get-accessor-method-function")))
-	      ,(get-optimized-std-slot-value-using-class-method-function
-		class slotd type)))
-	   (unless (and (eq type 'writer)
-			(dolist (method methods t)
-			  (unless (eq (car (method-specializers method))
-				      *the-class-t*)
-			    (return nil))))
-	     (let ((wrappers (list (wrapper-of class)
-				   (class-wrapper class)
-				   (wrapper-of slotd))))
-	       (if (eq type 'writer)
-		   (cons (class-wrapper *the-class-t*) wrappers)
-		   wrappers))))
-	  type))
+	 (let* ((optimized-std-fun
+		 (get-optimized-std-slot-value-using-class-method-function
+		  class slotd type))
+		(method-alist
+		 `((,(car (or (member std-method methods)
+			      (member str-method methods)
+			      (bug "error in ~S"
+				   'get-accessor-method-function)))
+		    ,optimized-std-fun)))
+		(wrappers
+		 (let ((wrappers (list (wrapper-of class)
+				       (class-wrapper class)
+				       (wrapper-of slotd))))
+		   (if (eq type 'writer)
+		       (cons (class-wrapper *the-class-t*) wrappers)
+		       wrappers)))
+		(sdfun (get-secondary-dispatch-function 
+			gf methods types method-alist wrappers)))
+	   (get-accessor-from-svuc-method-function class slotd sdfun type)))
      std-p)))
 
 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- std-class.lisp	24 Apr 2003 15:22:51 -0000	1.45
+++ std-class.lisp	28 Apr 2003 11:00:30 -0000	1.46
@@ -86,6 +86,20 @@
 	(compute-slot-accessor-info slotd type gf)))
     (initialize-internal-slot-gfs name)))
 
+;;; CMUCL (Gerd PCL 2003-04-25) comment:
+;;;
+;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
+;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
+;;; writing/testing effective slot SLOTD.
+;;;
+;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
+;;; GF.  Store the effective method in the effective slot definition
+;;; object itself; these GFs have special dispatch functions calling
+;;; effective methods directly retrieved from effective slot
+;;; definition objects, as an optimization.
+;;;
+;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
+;;; or some such.
 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
 				       type gf)
   (let* ((name (slot-value slotd 'name))
@@ -916,18 +930,9 @@
   (setf (plist-value class 'default-initargs) inits))
 
 (defmethod compute-default-initargs ((class slot-class))
-  (let ((cpl (class-precedence-list class))
-	(direct (class-direct-default-initargs class)))
-    (labels ((walk (tail)
-	       (if (null tail)
-		   nil
-		   (let ((c (pop tail)))
-		     (append (if (eq c class)
-				 direct
-				 (class-direct-default-initargs c))
-			     (walk tail))))))
-      (let ((initargs (walk cpl)))
-	(delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
+  (let ((initargs (loop for c in (class-precedence-list class)
+			append (class-direct-default-initargs c))))
+    (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
 
 ;;;; protocols for constructing direct and effective slot definitions