jyapayne/swig
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add a whole bunch of chicken runme scripts, and fix the bugs exposed by those scripts

Browse source 
git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@7155 626c5289-ae23-0410-ae9c-e8d60b6d4f22
This commit is contained in:
John Lenz 2005-04-15 05:23:14 +00:00
commit 420ba48099
72 changed files with 1085 additions and 412 deletions
Download patch file Download diff file Expand all files Collapse all files

130
SWIG/Lib/chicken/tinyclos-multi-generic.patch
View file

@ -3,13 +3,60 @@
# 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-04 23:35:10.000000000 -0500
+++ tinyclos.scm 2005-04-05 14:03:26.740306763 -0500
@@ -868,13 +868,24 @@
--- 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
@ -20,28 +67,49 @@
- [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 ([l1 (length (method-specializers method))]
+ [l2 (length (method-specializers (##sys#slot methods 0)))])
+ (cond ((> l1 l2)
+ (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
+ ((< l1 l2)
+ (cons method methods))
+ (else
+ (let check-method ([ms1 (method-specializers method)]
+ [ms2 (method-specializers (##sys#slot methods 0))])
+ (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 (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))
+ (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) )
@@ -946,9 +957,13 @@
@@ -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)
@ -58,7 +126,7 @@
(generic-methods generic) ) ] )
(if (or (null? applicable) (null? (##sys#slot applicable 1)))
applicable
@@ -975,8 +990,10 @@
@@ -975,8 +1001,10 @@
[else
(cond ((and (null? specls1) (null? specls2))
(##sys#error "two methods are equally specific" generic))
@ -71,12 +139,12 @@
((null? args)
(##sys#error "fewer arguments than specializers" generic))
(else
@@ -1235,7 +1252,7 @@
(define <tcp-listener> (make-primitive-class "tcp-listener" <structure>))
(define <c++-object> (make <class> 'name "c++-object" 'direct-supers (list <object>) 'direct-slots '(this)))
-(set! method-caching-enabled #t)
+;(set! method-caching-enabled #t)
;;; Utilities:
@@ -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>))