1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
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>))
|
