D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
usr
/
share
/
swig
/
2.0.10
/
chicken
/
Filename :
tinyclos-multi-generic.patch
back
Copy
# 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>))