projects / OpenSPARC-T2-SAM / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 architecture model.
[OpenSPARC-T2-SAM] / sam-t2 / devtools / v9 / share / swig / 1.3.26 / chicken / tinyclos-multi-generic.patch
CommitLineData
920dae64
AT		 1# This patch is against chicken 1.92, but it should work just fine
2# with older versions of chicken. It adds support for mulit-argument
3# generics, that is, generics now correctly handle adding methods
4# with different lengths of specializer lists
5
6# This patch has been committed into the CHICKEN darcs repository,
7# so chicken versions above 1.92 work fine.
8
9# Comments, bugs, suggestions send to chicken-users@nongnu.org
10
11# Patch written by John Lenz <lenz@cs.wisc.edu>
12
13--- tinyclos.scm.old 2005-04-05 01:13:56.000000000 -0500
14+++ tinyclos.scm 2005-04-11 16:37:23.746181489 -0500
15@@ -37,8 +37,10 @@
16
17 (include "parameters")
18
19+(cond-expand [(not chicken-compile-shared) (declare (unit tinyclos))]
20+ [else] )
21+
22 (declare
23- (unit tinyclos)
24 (uses extras)
25 (usual-integrations)
26 (fixnum)
27@@ -234,7 +236,10 @@
28 y = C_block_item(y, 1);
29 }
30 }
31- return(C_block_item(v, i + 1));
32+ if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST)
33+ return(C_block_item(v, i + 1));
34+ else
35+ goto mismatch;
36 }
37 else if(free_index == -1) free_index = i;
38 mismatch:
39@@ -438,7 +443,7 @@
40 (define hash-arg-list
41 (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) "
42 C_word tag, h, x;
43- int n, i, j;
44+ int n, i, j, len = 0;
45 for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) {
46 x = C_block_item(args, 0);
47 if(C_immediatep(x)) {
48@@ -481,8 +486,9 @@
49 default: i += 255;
50 }
51 }
52+ ++len;
53 }
54- return(i & (C_METHOD_CACHE_SIZE - 1));") )
55+ return((i + len) & (C_METHOD_CACHE_SIZE - 1));") )
56
57
58 ;
59@@ -868,13 +874,27 @@
60 (##tinyclos#slot-set!
61 generic
62 'methods
63- (cons method
64- (filter-in
65- (lambda (m)
66- (let ([ms1 (method-specializers m)]
67- [ms2 (method-specializers method)] )
68- (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) )
69- (##tinyclos#slot-ref generic 'methods))))
70+ (let* ([ms1 (method-specializers method)]
71+ [l1 (length ms1)] )
72+ (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)])
73+ (if (null? methods)
74+ (list method)
75+ (let* ([mm (##sys#slot methods 0)]
76+ [ms2 (method-specializers mm)]
77+ [l2 (length ms2)])
78+ (cond ((> l1 l2)
79+ (cons mm (filter-in-method (##sys#slot methods 1))))
80+ ((< l1 l2)
81+ (cons method methods))
82+ (else
83+ (let check-method ([ms1 ms1]
84+ [ms2 ms2])
85+ (cond ((and (null? ms1) (null? ms2))
86+ (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
87+ ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
88+ (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
89+ (else
90+ (cons mm (filter-in-method (##sys#slot methods 1)))))))))))))
91 (if (memq generic generic-invocation-generics)
92 (set! method-cache-tag (vector))
93 (%entity-cache-set! generic #f) )
94@@ -925,11 +945,13 @@
95 (memq (car args) generic-invocation-generics))
96 (let ([proc
97 (method-procedure
98+ ; select the first method of one argument
99 (let lp ([lis (generic-methods generic)])
100- (let ([tail (##sys#slot lis 1)])
101- (if (null? tail)
102- (##sys#slot lis 0)
103- (lp tail)) ) ) ) ] )
104+ (if (null? lis)
105+ (##sys#error "Unable to find original compute-apply-generic")
106+ (if (= (length (method-specializers (##sys#slot lis 0))) 1)
107+ (##sys#slot lis 0)
108+ (lp (##sys#slot lis 1)))))) ] )
109 (lambda (args) (apply proc #f args)) )
110 (let ([x (compute-apply-methods generic)]
111 [y ((compute-methods generic) args)] )
112@@ -946,9 +968,13 @@
113 (lambda (args)
114 (let ([applicable
115 (filter-in (lambda (method)
116- (every2 applicable?
117- (method-specializers method)
118- args))
119+ (let check-applicable ([list1 (method-specializers method)]
120+ [list2 args])
121+ (cond ((null? list1) #t)
122+ ((null? list2) #f)
123+ (else
124+ (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
125+ (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
126 (generic-methods generic) ) ] )
127 (if (or (null? applicable) (null? (##sys#slot applicable 1)))
128 applicable
129@@ -975,8 +1001,10 @@
130 [else
131 (cond ((and (null? specls1) (null? specls2))
132 (##sys#error "two methods are equally specific" generic))
133- ((or (null? specls1) (null? specls2))
134- (##sys#error "two methods have different number of specializers" generic))
135+ ;((or (null? specls1) (null? specls2))
136+ ; (##sys#error "two methods have different number of specializers" generic))
137+ ((null? specls1) #f)
138+ ((null? specls2) #t)
139 ((null? args)
140 (##sys#error "fewer arguments than specializers" generic))
141 (else
142@@ -1210,7 +1238,7 @@
143 (define <structure> (make-primitive-class "structure"))
144 (define <procedure> (make-primitive-class "procedure" <procedure-class>))
145 (define <end-of-file> (make-primitive-class "end-of-file"))
146-(define <environment> (make-primitive-class "environment" <structure>)) ; (Benedikt insisted on this)
147+(define <environment> (make-primitive-class "environment" <structure>))
148 (define <hash-table> (make-primitive-class "hash-table" <structure>))
149 (define <promise> (make-primitive-class "promise" <structure>))
150 (define <queue> (make-primitive-class "queue" <structure>))
Full OpenSPARC architecture tarball including simulator, hypervisor, and OBP.