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")) 54