EVOLUTION-MANAGER

Edit File: tinyclos-multi-generic.patch

# This patch is against chicken 1.92, but it should work just fine
# with older versions of chicken.  It adds support for mulit-argument
# generics, that is, generics now correctly handle adding methods
# with different lengths of specializer lists

# This patch has been committed into the CHICKEN darcs repository,
# so chicken versions above 1.92 work fine.

# Comments, bugs, suggestions send to chicken-users@nongnu.org

# Patch written by John Lenz <lenz@cs.wisc.edu>

--- tinyclos.scm.old	2005-04-05 01:13:56.000000000 -0500
+++ tinyclos.scm	2005-04-11 16:37:23.746181489 -0500
@@ -37,8 +37,10 @@
 
 (include "parameters")
 
+(cond-expand [(not chicken-compile-shared) (declare (unit tinyclos))]
+	     [else] )
+
 (declare
-  (unit tinyclos)
   (uses extras)
   (usual-integrations)
   (fixnum) 
@@ -234,7 +236,10 @@
             y = C_block_item(y, 1);
           }
         }
-        return(C_block_item(v, i + 1));
+        if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST)
+          return(C_block_item(v, i + 1));
+        else
+          goto mismatch;
       }
       else if(free_index == -1) free_index = i;
     mismatch:
@@ -438,7 +443,7 @@
 (define hash-arg-list
   (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) "
     C_word tag, h, x;
-    int n, i, j;
+    int n, i, j, len = 0;
     for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) {
       x = C_block_item(args, 0);
       if(C_immediatep(x)) {
@@ -481,8 +486,9 @@
         default: i += 255;
         }
       }
+      ++len;
     }
-    return(i & (C_METHOD_CACHE_SIZE - 1));") )
+    return((i + len) & (C_METHOD_CACHE_SIZE - 1));") )
 
 
 ;
@@ -868,13 +874,27 @@
     (##tinyclos#slot-set!
      generic
      'methods
-     (cons method
-	   (filter-in
-	    (lambda (m) 
-	      (let ([ms1 (method-specializers m)]
-		    [ms2 (method-specializers method)] )
-		(not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) )
-	    (##tinyclos#slot-ref generic 'methods))))
+     (let* ([ms1 (method-specializers method)]
+	    [l1 (length ms1)] )
+       (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)])
+	 (if (null? methods)
+	     (list method)
+	     (let* ([mm (##sys#slot methods 0)]
+		    [ms2 (method-specializers mm)]
+		    [l2 (length ms2)])
+	       (cond ((> l1 l2)
+		      (cons mm (filter-in-method (##sys#slot methods 1))))
+		     ((< l1 l2)
+		      (cons method methods))
+		     (else
+		      (let check-method ([ms1 ms1]
+					 [ms2 ms2])
+			(cond ((and (null? ms1) (null? ms2))
+			       (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
+			      ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
+			       (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
+			      (else
+			       (cons mm (filter-in-method (##sys#slot methods 1)))))))))))))
     (if (memq generic generic-invocation-generics)
 	(set! method-cache-tag (vector))
 	(%entity-cache-set! generic #f) )
@@ -925,11 +945,13 @@
 				(memq (car args) generic-invocation-generics))
 			   (let ([proc 
 				  (method-procedure
+				    ; select the first method of one argument
 				   (let lp ([lis (generic-methods generic)])
-				     (let ([tail (##sys#slot lis 1)])
-				       (if (null? tail)
-					   (##sys#slot lis 0)
-					   (lp tail)) ) ) ) ] )
+				     (if (null? lis)
+				       (##sys#error "Unable to find original compute-apply-generic")
+				       (if (= (length (method-specializers (##sys#slot lis 0))) 1)
+					 (##sys#slot lis 0)
+					 (lp (##sys#slot lis 1)))))) ] )
 			     (lambda (args) (apply proc #f args)) )
 			   (let ([x (compute-apply-methods generic)]
 				 [y ((compute-methods generic) args)] )
@@ -946,9 +968,13 @@
       (lambda (args)
 	(let ([applicable
 	       (filter-in (lambda (method)
-			    (every2 applicable?
-				   (method-specializers method)
-				   args))
+                            (let check-applicable ([list1 (method-specializers method)]
+                                                   [list2 args])
+                              (cond ((null? list1) #t)
+                                    ((null? list2) #f)
+                                    (else
+                                      (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
+                                           (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
 			  (generic-methods generic) ) ] )
 	  (if (or (null? applicable) (null? (##sys#slot applicable 1))) 
 	      applicable
@@ -975,8 +1001,10 @@
 	   [else
 	    (cond ((and (null? specls1) (null? specls2))
 		   (##sys#error "two methods are equally specific" generic))
-		  ((or (null? specls1) (null? specls2))
-		   (##sys#error "two methods have different number of specializers" generic))
+		  ;((or (null? specls1) (null? specls2))
+		  ; (##sys#error "two methods have different number of specializers" generic))
+                  ((null? specls1) #f)
+                  ((null? specls2) #t)
 		  ((null? args)
 		   (##sys#error "fewer arguments than specializers" generic))
 		  (else
@@ -1210,7 +1238,7 @@
 (define <structure>      (make-primitive-class "structure"))
 (define <procedure> (make-primitive-class "procedure" <procedure-class>))
 (define <end-of-file> (make-primitive-class "end-of-file"))
-(define <environment> (make-primitive-class "environment" <structure>))	; (Benedikt insisted on this)
+(define <environment> (make-primitive-class "environment" <structure>))
 (define <hash-table> (make-primitive-class "hash-table" <structure>))
 (define <promise> (make-primitive-class "promise" <structure>))
 (define <queue> (make-primitive-class "queue" <structure>))