You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
150 lines
5.6 KiB
150 lines
5.6 KiB
# 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>))
|
|
|