1 # This patch is against chicken 1.92, but it should work just fine 2 # with older versions of chicken. It adds support for mulit-argument 3 # generics, that is, generics now correctly handle adding methods 4 # with different lengths of specializer lists 5 6 # This patch has been committed into the CHICKEN darcs repository, 7 # so chicken versions above 1.92 work fine. 8 9 # Comments, bugs, suggestions send to chicken-users (a] nongnu.org 10 11 # Patch written by John Lenz <lenz (a] cs.wisc.edu> 12 13 --- tinyclos.scm.old 2005-04-05 01:13:56.000000000 -0500 14 +++ tinyclos.scm 2005-04-11 16:37:23.746181489 -0500 15 @@ -37,8 +37,10 @@ 16 17 (include "parameters") 18 19 +(cond-expand [(not chicken-compile-shared) (declare (unit tinyclos))] 20 + [else] ) 21 + 22 (declare 23 - (unit tinyclos) 24 (uses extras) 25 (usual-integrations) 26 (fixnum) 27 @@ -234,7 +236,10 @@ 28 y = C_block_item(y, 1); 29 } 30 } 31 - return(C_block_item(v, i + 1)); 32 + if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST) 33 + return(C_block_item(v, i + 1)); 34 + else 35 + goto mismatch; 36 } 37 else if(free_index == -1) free_index = i; 38 mismatch: 39 @@ -438,7 +443,7 @@ 40 (define hash-arg-list 41 (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) " 42 C_word tag, h, x; 43 - int n, i, j; 44 + int n, i, j, len = 0; 45 for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) { 46 x = C_block_item(args, 0); 47 if(C_immediatep(x)) { 48 @@ -481,8 +486,9 @@ 49 default: i += 255; 50 } 51 } 52 + ++len; 53 } 54 - return(i & (C_METHOD_CACHE_SIZE - 1));") ) 55 + return((i + len) & (C_METHOD_CACHE_SIZE - 1));") ) 56 57 58 ; 59 @@ -868,13 +874,27 @@ 60 (##tinyclos#slot-set! 61 generic 62 'methods 63 - (cons method 64 - (filter-in 65 - (lambda (m) 66 - (let ([ms1 (method-specializers m)] 67 - [ms2 (method-specializers method)] ) 68 - (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) ) 69 - (##tinyclos#slot-ref generic 'methods)))) 70 + (let* ([ms1 (method-specializers method)] 71 + [l1 (length ms1)] ) 72 + (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)]) 73 + (if (null? methods) 74 + (list method) 75 + (let* ([mm (##sys#slot methods 0)] 76 + [ms2 (method-specializers mm)] 77 + [l2 (length ms2)]) 78 + (cond ((> l1 l2) 79 + (cons mm (filter-in-method (##sys#slot methods 1)))) 80 + ((< l1 l2) 81 + (cons method methods)) 82 + (else 83 + (let check-method ([ms1 ms1] 84 + [ms2 ms2]) 85 + (cond ((and (null? ms1) (null? ms2)) 86 + (cons method (##sys#slot methods 1))) ;; skip the method already in the generic 87 + ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0)) 88 + (check-method (##sys#slot ms1 1) (##sys#slot ms2 1))) 89 + (else 90 + (cons mm (filter-in-method (##sys#slot methods 1))))))))))))) 91 (if (memq generic generic-invocation-generics) 92 (set! method-cache-tag (vector)) 93 (%entity-cache-set! generic #f) ) 94 @@ -925,11 +945,13 @@ 95 (memq (car args) generic-invocation-generics)) 96 (let ([proc 97 (method-procedure 98 + ; select the first method of one argument 99 (let lp ([lis (generic-methods generic)]) 100 - (let ([tail (##sys#slot lis 1)]) 101 - (if (null? tail) 102 - (##sys#slot lis 0) 103 - (lp tail)) ) ) ) ] ) 104 + (if (null? lis) 105 + (##sys#error "Unable to find original compute-apply-generic") 106 + (if (= (length (method-specializers (##sys#slot lis 0))) 1) 107 + (##sys#slot lis 0) 108 + (lp (##sys#slot lis 1)))))) ] ) 109 (lambda (args) (apply proc #f args)) ) 110 (let ([x (compute-apply-methods generic)] 111 [y ((compute-methods generic) args)] ) 112 @@ -946,9 +968,13 @@ 113 (lambda (args) 114 (let ([applicable 115 (filter-in (lambda (method) 116 - (every2 applicable? 117 - (method-specializers method) 118 - args)) 119 + (let check-applicable ([list1 (method-specializers method)] 120 + [list2 args]) 121 + (cond ((null? list1) #t) 122 + ((null? list2) #f) 123 + (else 124 + (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0)) 125 + (check-applicable (##sys#slot list1 1) (##sys#slot list2 1))))))) 126 (generic-methods generic) ) ] ) 127 (if (or (null? applicable) (null? (##sys#slot applicable 1))) 128 applicable 129 @@ -975,8 +1001,10 @@ 130 [else 131 (cond ((and (null? specls1) (null? specls2)) 132 (##sys#error "two methods are equally specific" generic)) 133 - ((or (null? specls1) (null? specls2)) 134 - (##sys#error "two methods have different number of specializers" generic)) 135 + ;((or (null? specls1) (null? specls2)) 136 + ; (##sys#error "two methods have different number of specializers" generic)) 137 + ((null? specls1) #f) 138 + ((null? specls2) #t) 139 ((null? args) 140 (##sys#error "fewer arguments than specializers" generic)) 141 (else 142 @@ -1210,7 +1238,7 @@ 143 (define <structure> (make-primitive-class "structure")) 144 (define <procedure> (make-primitive-class "procedure" <procedure-class>)) 145 (define <end-of-file> (make-primitive-class "end-of-file")) 146 -(define <environment> (make-primitive-class "environment" <structure>)) ; (Benedikt insisted on this) 147 +(define <environment> (make-primitive-class "environment" <structure>)) 148 (define <hash-table> (make-primitive-class "hash-table" <structure>)) 149 (define <promise> (make-primitive-class "promise" <structure>)) 150 (define <queue> (make-primitive-class "queue" <structure>)) 151
