diff options
Diffstat (limited to 'Lib/chicken/tinyclos-multi-generic.patch')
| -rw-r--r-- | Lib/chicken/tinyclos-multi-generic.patch | 150 |
1 files changed, 0 insertions, 150 deletions
diff --git a/Lib/chicken/tinyclos-multi-generic.patch b/Lib/chicken/tinyclos-multi-generic.patch deleted file mode 100644 index 2e585960e..000000000 --- a/Lib/chicken/tinyclos-multi-generic.patch +++ /dev/null @@ -1,150 +0,0 @@ -# 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>)) |