| 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@nongnu.org |
| 10 | |
| 11 | # Patch written by John Lenz <lenz@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>)) |