123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150 |
- # 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>))
|