[Sbcl-commits] CVS: sbcl/src/pcl generic-functions.lisp,1.17,1.18 std-class.lisp,1.42,1.43

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

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

Modified Files:
	generic-functions.lisp std-class.lisp 
Log Message:
0.pre8.65:
	Make COMPUTE-EFFECTIVE-SLOT-DEFINITION (more) AMOP compliant, as 
		per KMR cmucl-imp 2003-04-12
	... write a FIXME in the test, because I don't understand the 
		required behaviour, but it's better than it was.


Index: generic-functions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/generic-functions.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- generic-functions.lisp	29 Mar 2003 15:14:30 -0000	1.17
+++ generic-functions.lisp	17 Apr 2003 15:34:02 -0000	1.18
@@ -328,8 +328,6 @@
 (defgeneric compute-applicable-methods-using-classes
   (generic-function classes))
 
-(defgeneric compute-effective-slot-definition (class dslotds))
-
 (defgeneric compute-effective-slot-definition-initargs (class direct-slotds))
 
 (defgeneric describe-object (object stream))
@@ -414,6 +412,8 @@
 (defgeneric compute-effective-method (generic-function
 				      combin
 				      applicable-methods))
+
+(defgeneric compute-effective-slot-definition (class name dslotds))
 
 (defgeneric compute-slot-accessor-info (slotd type gf))
 

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- std-class.lisp	4 Apr 2003 14:25:36 -0000	1.42
+++ std-class.lisp	17 Apr 2003 15:34:02 -0000	1.43
@@ -895,6 +895,7 @@
 	      (push (list name slot) name-dslotds-alist)))))
     (mapcar (lambda (direct)
 	      (compute-effective-slot-definition class
+						 (car direct)
 						 (nreverse (cdr direct))))
 	    name-dslotds-alist)))
 
@@ -968,8 +969,10 @@
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
 	    (mapcar (lambda (dslotd)
-		      (compute-effective-slot-definition class
-							 (list dslotd)))
+		      (compute-effective-slot-definition
+		       class
+		       (slot-definition-name dslotd)
+		       (list dslotd)))
 		    (class-direct-slots superclass)))
 	  (reverse (slot-value class 'class-precedence-list))))
 
@@ -978,7 +981,8 @@
     (mapc #'initialize-internal-slot-functions eslotds)
     eslotds))
 
-(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
+(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
+  (declare (ignore name))
   (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
 	 (class (effective-slot-definition-class class initargs)))
     (apply #'make-instance class initargs)))