~ chicken-core (master) /tests/apply-test.scm

 1(import (chicken format)
 2        (chicken platform)
 3	(chicken fixnum))
 4
 5(import-for-syntax (chicken fixnum))
 6
 7(define (list-tabulate n proc)
 8  (let loop ((i 0))
 9    (if (fx>= i n)
10	'()
11	(cons (proc i) (loop (fx+ i 1))))))
12
13(define-for-syntax (list-tabulate n proc)
14  (let loop ((i 0))
15    (if (fx>= i n)
16	'()
17	(cons (proc i) (loop (fx+ i 1))))))
18
19(define (last lst)
20  (let loop ((lst lst))
21    (if (null? (cdr lst))
22	(car lst)
23	(loop (cdr lst)))))
24
25(define (foo . args)
26  (when (pair? args)
27    (assert (= (length args) (last args)))))
28
29(printf "testing 'apply' with 0..~A...\n" 2000)
30(do ((i 0 (add1 i)))
31    ((>= i 2000))
32  (apply foo (list-tabulate i add1)))
33
34(print "testing 'apply' with 10000...")
35(apply foo (list-tabulate 10000 add1))
36
37(let-syntax
38    ((invoke-directly
39      (ir-macro-transformer
40       (lambda (e r c)
41	 (let ((proc (cadr e))
42	       (count (caddr e))
43	       (end (cadddr e))
44	       (message (car (cddddr e))))
45	   `(begin
46	      (printf "invoking directly with ~A..~A (~A)...\n"
47		,(- end count) ,end ,message)
48	      ,@(list-tabulate
49		 count
50		 (lambda (i)
51		   `(,proc ,@(list-tabulate (- end i) add1))))))))))
52  (invoke-directly foo 50 50 "Lower edge case")
53  (invoke-directly foo 50 2000 "Higher edge case"))