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