tmtt/chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull requests Releases 1 Activity

feat: 9.5.9

Browse source
This commit is contained in:
tmtt 2022-07-29 15:12:07 +02:00
parent cb1753732b
commit 35f43a7909
1084 changed files with 558985 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

926
nanopass/tests/alltests.ss Normal file
View file

@ -0,0 +1,926 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests alltests)
(export main-tests final-tests)
(import (rnrs))
(define main-tests
'(
'()
(- 2 4)
(* -6 7)
(cons 0 '())
(cons (cons 0 '()) (cons 1 '()))
(void)
(if #f 3)
(let ((x 0)) x)
(let ([x 0]) x x)
(let ([q (add1 (add1 2))]) q)
(+ 20 (if #t 122))
(if #t
(+ 20
(if #t 122))
10000)
(not (if #f #t (not #f)))
(let ([x 0][y 4000]) x)
(begin (if #f 7) 3)
(begin (if (zero? 4) 7) 3)
(let ([x 0]) (begin (if (zero? x) 7) x))
(let ([x 0]) (begin (if (zero? x) (begin x 7)) x))
(let ([x 0] [z 9000])
(begin (if (zero? x) (begin x 7)) z))
(let ([x 0] [z 9000])
(begin (if (zero? x) (begin (set! x x) 7))
(+ x z)))
(let ([x (cons 0 '())])
(begin (if x (set-car! x (car x))) x))
(let ([x (cons 0 '())])
(begin (if x (set-car! x (+ (car x) (car x)))) x))
(let ([x (cons 0 '())])
(if (zero? (car x)) (begin (set-car! x x) 7) x))
(let ([x (cons 0 '())])
(let ([q x]) (if (zero? (car x)) (begin (set-car! q x) 7) x)))
(let ([x 0]) (if (zero? x) (begin (set! x (+ x 5000)) x) 20))
(let ([y 0]) (begin (if #t (set! y y)) y))
(begin (if #t #t #t) #f)
(begin (if (if #t #t #f) (if #t #t #f) (if #t #t #f)) #f)
(let ([x 0] [y 4000] [z 9000])
(let ((q (+ x z)))
(begin
(if (zero? x) (begin (set! q (+ x x)) 7))
(+ y y)
(+ x z))))
(let ([x (let ([y 2]) y)] [y 5])
(add1 x))
(let ([y 4000]) (+ y y))
((lambda (y) y) 4000)
(let ([f (lambda (x) x)])
(add1 (f 0)))
(let ([f (lambda (y) y)]) (f (f 4)))
((lambda (f) (f (f 4))) (lambda (y) y))
((let ([a 4000])
(lambda (b) (+ a b)))
5000)
(((lambda (a)
(lambda (b)
(+ a b)))
4000)
5000)
(let ([f (lambda (x) (add1 x))]) (f (f 0)))
((lambda (f) (f (f 0))) (lambda (x) (add1 x)))
(let ([x 0] [f (lambda (x) x)])
(let ([a (f x)] [b (f x)] [c (f x)]) (+ (+ a b) c)))
(let ([x 0][y 1][z 2][f (lambda (x) x)])
(let ([a (f x)][b (f y)][c (f z)])
(+ (+ a b) c)))
(let ([f (lambda (x y) x)])
(f 0 1))
(let ([f (lambda (x y) x)])
(let ([a (f 0 1)]) (f a a)))
(let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
(let ([a (f x y z)]) (f a a a)))
(let ([x 0] [y 1] [z 2] [f (lambda (x y z) x)])
(let ([a (f x y z)] [b y] [c z]) (f a b c)))
(let ([f (lambda (a b c d)
(+ a d))])
(f 0 1 2 3))
(let ([f (lambda (x) x)])
(+ (f 0)
(let ([a 0] [b 1] [c 2])
(+ (f a) (+ (f b) (f c))))))
(let ([f (lambda (x) x)])
(+ (f 0)
(let ([a 0] [b 1] [c 2])
(add1 (f a)))))
(let ([f (lambda (x) x)])
(+ (f 0) (let ([a 0][b 1][c 2][d 3])
(+ (f a)
(+ (f b)
(+ (f c)
(f d)))))))
(let ([a 0])(letrec ([a (lambda () 0)][b (lambda () 11)]) (set! a 11)))
(let ([a 0])(letrec ([a (lambda () (set! a 0))][b 11]) (a)))
(let ([a 0])(let ([a (set! a 0)][b 11]) a))
(let ([a 5]) (let ([a 0] [b (set! a (+ a 11))]) a))
(letrec ([a (lambda () 0)]) (a))
(letrec ([a (lambda () 0)] [b (lambda () 11)]) (a))
(let ([x 0]) (letrec ([a (lambda () 0)] [b (lambda () 11)]) (set! x 11)))
(let ([a 0]) (let ([b (set! a 0)]) a))
(let ([a 0])(let ([a (set! a 0)]) (let ([b 11]) a)))
(let ([a 0])(let ([a 0]) (let ([b (set! a 11)]) a)))
(let ([a 0])(let ([a 0]) (let ([b 11]) (set! a 11))))
(let ([f (let ([x 1]) (lambda (y) (+ x y)))])
(let ([x 0]) (f (f x))))
((let ([t (lambda (x) (+ x 50))])
(lambda (f) (t (f 1000))))
(lambda (y) (+ y 2000)))
(let ([x 0])
(let ([f (let ([x 1] [z x])
(lambda (y)
(+ x (+ z y))))])
(f (f x))))
(((lambda (t)
(lambda (f) (t (f 1000))))
(lambda (x) (+ x 50)))
(lambda (y) (+ y 2000)))
((let ([t 50])
(lambda (f)
(+ t (f))))
(lambda () 2000))
(((lambda (t)
(lambda (f)
(+ t (f))))
50)
(lambda () 2000))
((let ([x 300])
(lambda (y) (+ x y)))
400)
(let ([x 3] [f (lambda (x y) x)])
(f (f 0 0) x))
(let ([x 3] [f (lambda (x y) x)])
(if (f 0 0) (f (f 0 0) x) 0))
(let ([x02 3] [f01 (lambda (x04 y03) x04)])
(if (not x02) (f01 (f01 0 0) x02) 0))
(let ((f (lambda (x) (if (if (pair? x) (not (eq? (car x) 0)) #f) x #f))))
(f (cons 0 0)))
(let ((f (lambda (x)
(if (if x (not (if (pair? x) (not (eq? (car x) 0)) #f)) #f)
x #f))))
(f 0))
(let ((f (lambda (x) (if (if (pair? x) #t (null? x)) x '()))))
(f 0))
(let ([y 4])
(let ([f (lambda (y) y)])
(f (f y))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y y) (f y y))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y y) (f y (f y y)))))
(let ([y 4])
(let ([f (lambda (x y) 0)])
(f (f y (f y y)) (f y (f y y)))))
((lambda (y) ((lambda (f) (f (f y))) (lambda (y) y))) 4)
(let ([f (lambda (x) (+ x x))]) (f 4000))
(let ((x (if 1000 2000 3000))) x)
(let ([f (lambda (x) x)]) (add1 (if #f 1 (f 22))))
(let ([f (lambda (x) x)]) (if (f (zero? 23)) 1 22))
(let ([f (lambda (x) (if x (not x) x))]
[f2 (lambda (x) (* 10 x))]
[x 23])
(add1 (if (f (zero? x)) 1 (* x (f2 (sub1 x))))))
(let ([f (lambda () 0)])
(let ([x (f)]) 1))
(let ([f (lambda () 0)])
(begin (f) 1))
(let ([f (lambda (x) x)])
(if #t (begin (f 3) 4) 5))
(let ([f (lambda (x) x)])
(begin (if #t (f 4) 5) 6))
(let ([f (lambda (x) x)])
(begin (if (f #t)
(begin (f 3) (f 4))
(f 5))
(f 6)))
(let ([f (lambda (x) (add1 x))])
(f (let ([f 3]) (+ f 1))))
(let ((x 15)
(f (lambda (h v) (* h v)))
(k (lambda (x) (+ x 5)))
(g (lambda (x) (add1 x))))
(k (g (let ((g 3)) (f g x)))))
(let ([x 4])
(let ([f (lambda () x)])
(set! x 5)
(f)))
(let ([x (let ([y 2]) y)]) x)
(let ([x (if #t (let ([y 2]) y) 1)]) x)
(let ([x (let ([y (let ([z 3]) z)]) y)]) x)
(let ([x (if #t (let ([y (if #t (let ([z 3]) z) 2)]) y) 1)]) x)
(+ (let ([x 3]) (add1 x)) 4)
(+ (let ([x 3][y 4]) (* x y)) 4)
(let ([x (add1 (let ([y 4]) y))]) x)
(let ([x (add1 (letrec ([y (lambda () 4)]) (y)))]) x)
(let ([x (+ (let ([y 4]) y) (let ([y 4]) y))]) (add1 x))
(let ([z 0]) (let ([x z]) z x))
(let ([z 0]) (let ([x (begin (let ([y 2]) (set! z y)) z)]) x))
(let ([x (begin (let ([y 2]) (set! y y)) (let ([z 3]) z))]) x)
(letrec ([one (lambda (n) (if (zero? n) 1 (one (sub1 n))))])
(one 13))
(letrec ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
(odd 13))
(let ([t #t] [f #f])
(letrec ((even (lambda (x) (if (zero? x) t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) f (even (sub1 x))))))
(odd 13)))
(let ((even (lambda (x) x)))
(even (letrec ((even (lambda (x) (if (zero? x) #t (odd (sub1 x)))))
(odd (lambda (x) (if (zero? x) #f (even (sub1 x))))))
(odd 13))))
(letrec ((fact (lambda (n) (if (zero? n) 1 (* n (fact (sub1 n)))))))
(fact 5))
(let ([x 5])
(letrec ([a (lambda (u v w) (if (zero? u) (b v w) (a (- u 1) v w)))]
[b (lambda (q r)
(let ([p (* q r)])
(letrec
([e (lambda (n) (if (zero? n) (c p) (o (- n 1))))]
[o (lambda (n) (if (zero? n) (c x) (e (- n 1))))])
(e (* q r)))))]
[c (lambda (x) (* 5 x))])
(a 3 2 1)))
(let ([f (lambda () 80)]) (let ([a (f)] [b (f)]) 0))
(let ([f (lambda () 80)]) (let ([a (f)] [b (f)]) (* a b)))
(let ([f (lambda () 80)] [g (lambda () 80)])
(let ([a (f)] [b (g)])
(* a b)))
(let ((f (lambda (x) (add1 x)))
(g (lambda (x) (sub1 x)))
(t (lambda (x) (add1 x)))
(j (lambda (x) (add1 x)))
(i (lambda (x) (add1 x)))
(h (lambda (x) (add1 x)))
(x 80))
(let ((a (f x)) (b (g x)) (c (h (i (j (t x))))))
(* a (* b (+ c 0)))))
(let ((x 3000))
(if (integer? x)
(let ((y (cons x '())))
(if (if (pair? y) (null? (cdr y)) #f)
(+ x 5000)
(- x 3000)))))
(let ((x (cons 1000 2000)))
(if (pair? x)
(let ((temp (car x)))
(set-car! x (cdr x))
(set-cdr! x temp)
(+ (car x) (cdr x)))
10000000))
(let ((v (make-vector 3)))
(vector-set! v 0 10)
(vector-set! v 1 20)
(vector-set! v 2 30)
(if (vector? v)
(+ (+ (vector-length v) (vector-ref v 0))
(+ (vector-ref v 1) (vector-ref v 2)))
10000))
(let ([fact (lambda (fact n)
(if (zero? n) 1 (* (fact fact (sub1 n)) n)))])
(fact fact 5))
(let ([s (make-vector 20)])
(vector-set! s 19 #\z)
(if (vector? s)
(+ 20 (let ([c #\z]) (if (char? c) 122)))
10000))
(let ([s (make-vector 20)])
(vector-set! s 19 #\z)
(if (vector? s)
(+ (vector-length s)
(let ([c (vector-ref s 19)])
(if (char? c)
(char->integer (vector-ref s 19)))))
10000))
(let ((s (make-vector 20)) (s2 (make-vector 3)))
(vector-set! s 19 #\z)
(vector-set! s 18 #\t)
(vector-set! s2 0 #\a)
(if (vector? s)
(+ (vector-length s)
(let ((c (vector-ref s 18)))
(if (char? c)
(+ (char->integer (vector-ref s 19))
(char->integer c)))))
10000))
(let ([f (lambda (x) (+ x 1000))])
(if (zero? (f -2)) (f 6000) (f (f 8000))))
(let ([f (lambda (x) (+ x 1000))])
(if (zero? (f -1)) (f 6000) (f (f 8000))))
(let ((f (lambda (x y) (+ x 1000))))
(+ (if (f 3000 (begin 0 0 0)) (f (f 4000 0) 0) 8000) 2000))
((((lambda (x)
(lambda (y)
(lambda (z)
(+ x (+ y (+ z y))))))
5) 6) 7)
((((((lambda (x)
(lambda (y)
(lambda (z)
(lambda (w)
(lambda (u)
(+ x (+ y (+ z (+ w u)))))))))
5) 6) 7) 8) 9)
(let ((f (lambda (x) x)))
(if (procedure? f) #t #f))
(let ((sum (lambda (sum ls)
(if (null? ls) 0 (+ (car ls) (sum sum (cdr ls)))))))
(sum sum (cons 1 (cons 2 (cons 3 '())))))
(let ((v (make-vector 5))
(w (make-vector 7)))
(vector-set! v 0 #t)
(vector-set! w 3 #t)
(if (boolean? (vector-ref v 0))
(vector-ref w 3)
#f))
(let ((a 5) (b 4))
(if (< b 3)
(eq? a (+ b 1))
(if (<= b 3)
(eq? (- a 1) b)
(= a (+ b 2)))))
(let ((a 5) (b 4))
(if #f (eq? a (+ b 1)) (if #f (eq? (- a 1) b) (= a (+ b 2)))))
(((lambda (a) (lambda () (+ a (if #t 200)) 1500)) 1000))
(((lambda (b) (lambda (a) (set! a (if 1 2)) (+ a b))) 100) 200)
((((lambda (a)
(lambda (b)
(set! a (if b 200))
(lambda (c) (set! c (if 300 400))
(+ a (+ b c)))))
1000) 2000) 3000)
((((lambda (a) (lambda (b) (lambda (c) (+ a (+ b c))))) 10) 20) 30)
(+ 2 3)
((lambda (a) (+ 2 a)) 3)
(((lambda (b) (lambda (a) (+ b a))) 3) 2)
((lambda (b) ((lambda (a) (+ b a)) 2)) 3)
((lambda (f) (f (f 5))) (lambda (x) x))
((let ((f (lambda (x) (+ x 3000)))) (lambda (y) (f (f y)))) 2000)
(let ((n #\newline) (s #\space) (t #\tab))
(let ((st (make-vector 5)))
(vector-set! st 0 n)
(vector-set! st 1 s)
(vector-set! st 2 t)
(if (not (vector? st))
10000
(vector-length st))))
(let ((s (make-vector 1)))
(vector-set! s 0 #\c)
(if (eq? (vector-ref s 0) #\c) 1000 2000))
(not 17)
(not #f)
(let ([fact (lambda (fact n acc)
(if (zero? n) acc (fact fact (sub1 n) (* n acc))))])
(fact fact 5 1))
((lambda (b c a)
(let ((b (+ b a)) (a (+ a (let ((a (+ b b)) (c (+ c c))) (+ a a)))))
(* a a))) 2 3 4)
(let ((f (lambda (x) (lambda () (x))))) ((f (lambda () 3))))
(letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
(let ([q 17])
(let ((g (lambda (a) (set! q 10) (lambda () (a q)))))
((g f)))))
(letrec ((f (lambda (x) (if (zero? x) 1 (* x (f (- x 1)))))))
(let ((g (lambda (a) (lambda (b) (a b)))))
((g f) 10)))
(letrec ((f (lambda () (+ a b)))
(g (lambda (y) (set! g (lambda (y) y)) (+ y y)))
(a 17)
(b 35)
(h (cons (lambda () a) (lambda (v) (set! a v)))))
(let ((x1 (f)) (x2 (g 22)) (x3 ((car h))))
(let ((x4 (g 22)))
((cdr h) 3)
(let ((x5 (f)) (x6 ((car h))))
(cons x1 (cons x2 (cons x3 (cons x4 (cons x5 x6)))))))))
(letrec ((f (lambda () (+ a b)))
(a 17)
(b 35)
(h (cons (lambda () a) (lambda () b))))
(cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
(letrec ((f (lambda (x) (letrec ((x 3)) 3))))
(letrec ((g (lambda (x) (letrec ((y 14)) (set! y 7) y))))
(set! g (cons g 3))
(letrec ((h (lambda (x) x)) (z 42))
(cons (cdr g) (h z)))))
(let ([t #t] [f #f])
(let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
(letrec
([even (lambda (x) (if (zero? x) (id (car bools)) (odd (- x 1))))]
[odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
(odd 5))))
(letrec ([fib (lambda (x)
(let ([decrx (lambda () (set! x (- x 1)))])
(if (< x 2)
1
(+ (begin (decrx) (fib x))
(begin (decrx) (fib x))))))])
(fib 10))
(letrec ([fib (lambda (x)
(let ([decrx (lambda () (lambda (i) (set! x (- x i))))])
(if (< x 2)
1
(+ (begin ((decrx) 1) (fib x))
(begin ((decrx) 1) (fib x))))))])
(fib 10))
;; Jie Li
(let ((a 5))
(let ((b (cons a 6)))
(let ((f (lambda(x) (* x a))))
(begin (if (- (f a) (car b))
(begin (set-car! b (if (not a) (* 2 a) (+ 2 a)))
(f a))
(if (not (not (< (f a) b))) (f a)))
(not 3)
(void)
(f (car b))))))
(letrec ([f (lambda (x y)
(if (not x) (g (add1 x) (add1 y)) (h (+ x y))))]
[g (lambda (u v)
(let ([a (+ u v)] [b (* u v)])
(letrec ([e (lambda (d)
(letrec ([p (cons a b)]
[q (lambda (m)
(if (< m u)
(f m d)
(h (car p))))])
(q (f a b))))])
(e u))))]
[h (lambda (w) w)])
(f 4 5))
(letrec ((f (lambda (x)
(+ x (((lambda (y)
(lambda (z)
(+ y z)))
6) 7))))
(g (+ 5 ((lambda (w u) (+ w u)) 8 9))))
g)
;; Jordan Johnson
(let ((test (if (not (not 10)) #f 5)))
(letrec ([num 5]
[length
(lambda (ls)
(let ((len (if ((lambda (ck)
(begin ck (set! num test) ck))
(null? ls))
(begin num (set! num 0) num)
(begin (length '())
(set! num 5)
(+ 1 (length (cdr ls)))))))
(if len len)))])
(length (cons 5 (cons (if (set! num 50) (length (cons test '())) 1)
'())))))
(letrec ([quotient (lambda (x y)
(if (< x 0)
(- 0 (quotient (- 0 x) y))
(if (< y 0)
(- 0 (quotient x (- 0 y)))
(letrec ([f (lambda (x a)
(if (< x y)
a
(f (- x y) (+ a 1))))])
(f x 0)))))])
(letrec ([sub-interval 1]
[sub-and-continue
(lambda (n acc k) (k (- n sub-interval) (* n acc)))]
[strange-fact
(lambda (n acc)
(if (zero? n)
(lambda (proc) (proc acc))
(sub-and-continue n acc strange-fact)))])
(let ([x 20]
[fact (let ((seed 1)) (lambda (n) (strange-fact n seed)))])
(let ([give-fact5-answer (fact 5)]
[give-fact6-answer (fact 6)]
[answer-user (lambda (ans) (quotient ans x))])
(set! x (give-fact5-answer answer-user))
(begin (set! x (give-fact6-answer answer-user)) x)))))
(let ((y '()) (z 10))
(let ((test-ls (cons 5 y)))
(set! y (lambda (f)
((lambda (g) (f (lambda (x) ((g g) x))))
(lambda (g) (f (lambda (x) ((g g) x)))))))
(set! test-ls (cons z test-ls))
(letrec ((length (lambda (ls)
(if (null? ls) 0 (+ 1 (length (cdr ls)))))))
(let ((len (length test-ls)))
(eq? (begin
(set! length (y (lambda (len)
(lambda (ls)
(if (null? ls)
0
(+ 1 (len (cdr ls))))))))
(length test-ls))
len)))))
;; Ryan Newton
(letrec ((loop (lambda () (lambda () (loop))))) (loop) 0)
(letrec ([f (lambda ()
(letrec ([loop
(lambda (link)
(lambda ()
(link)))])
(loop (lambda () 668))))])
((f)))
;; AWK - the following test uses the syntax #36rgood and #36rbad,
;; which the ikarus reader seems to choak on, so I'm commenting out
;; this test for now.
; (if (lambda () 1)
; (let ((a 2))
; (if (if ((lambda (x)
; (let ((x (set! a (set! a 1))))
; x)) 1)
; (if (eq? a (void))
; #t
; #f)
; #f)
; #36rgood ; dyb: cannot use symbols, so use radix 36
; #36rbad))) ; syntax to make all letters digits
; contributed by Ryan Newton
(letrec ([dropsearch
(lambda (cell tree)
(letrec ([create-link
(lambda (node f)
(lambda (g)
(if (not (pair? node))
(f g)
(if (eq? node cell)
#f
(f (create-link
(car node)
(create-link
(cdr node) g)))))))]
[loop
(lambda (link)
(lambda ()
(if link
(loop (link (lambda (v) v)))
#f)))])
(loop (create-link tree (lambda (x) x)))))]
[racethunks
(lambda (thunkx thunky)
(if (if thunkx thunky #f)
(racethunks (thunkx) (thunky))
(if thunky
#t
(if thunkx
#f
'()))))]
[higher? (lambda (x y tree)
(racethunks (dropsearch x tree)
(dropsearch y tree)))]
[under?
(lambda (x y tree)
(racethunks (dropsearch x y)
(dropsearch x tree)))]
[explore
(lambda (x y tree)
(if (not (pair? y))
#t
(if (eq? x y)
#f ; takes out anything pointing to itself
(let ((result (higher? x y tree)))
(if (eq? result #t)
(if (explore y (car y) tree)
(explore y (cdr y) tree)
#f)
(if (eq? result #f)
(process-vertical-jump x y tree)
(if (eq? result '())
(process-horizontal-jump x y tree)
)))))))]
[process-vertical-jump
(lambda (jumpedfrom jumpedto tree)
(if (under? jumpedfrom jumpedto tree)
#f
(fullfinite? jumpedto)))]
[process-horizontal-jump
(lambda (jumpedfrom jumpedto tree)
(fullfinite? jumpedto))]
[fullfinite?
(lambda (pair)
(if (not (pair? pair))
#t
(if (explore pair (car pair) pair)
(explore pair (cdr pair) pair)
#f)))])
(cons (fullfinite? (cons 1 2))
(cons (fullfinite? (let ((x (cons 1 2))) (set-car! x x) x))
(cons (fullfinite?
(let ([a (cons 0 0)] [b (cons 0 0)] [c (cons 0 0)])
(set-car! a b) (set-cdr! a c) (set-cdr! b c)
(set-car! b c) (set-car! c b) (set-cdr! c b) a))
'()))))))
(define final-tests
; extracted tests from assignment writeups
'(75
(+ 16 32)
(* 16 128)
(let ((x 16) (y 128)) (* x y))
(let ([x 17]) (+ x x)) (cons 16 32) (cdr (cons 16 32))
(let ((x (cons 16 32))) (pair? x))
(let ([x 3]) (let ([y (+ x (quote 4))]) (+ x y)))
(let ([f (lambda (x) x)]) (let ([a 1]) (* (+ (f a) a) a)))
(let ([k (lambda (x y) x)])
(let ([b 17]) ((k (k k 37) 37) b (* b b))))
(let ([f (lambda ()
(let ([n 256])
(let ([v (make-vector n)])
(vector-set! v 32 n)
(vector-ref v 32))))])
(pair? (f)))
(let ((w 4) (x 8) (y 16) (z 32))
(let ((f (lambda ()
(+ w (+ x (+ y z))))))
(f)))
(let ((f (lambda (g u) (g (if u (g 37) u)))))
(f (lambda (x) x) 75))
(let ((f (lambda (h u) (h (if u (h (+ u 37)) u)))) (w 62))
(f (lambda (x) (- w x)) (* 75 w)))
(let ([t #t] [f #f])
(let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
(letrec
([even (lambda (x) (if (id (zero? x)) (car bools) (odd (- x 1))))]
[odd (lambda (y) (if (zero? y) (id (cdr bools)) (even (- y 1))))])
(odd 5))))
((lambda (x y z)
(let ((f (lambda (u v) (begin (set! x u) (+ x v))))
(g (lambda (r s) (begin (set! y (+ z s)) y))))
(* (f '1 '2) (g '3 '4))))
'10 '11 '12)
((lambda (x y z)
(let ((f '#f)
(g (lambda (r s) (begin (set! y (+ z s)) y))))
(begin
(set! f
(lambda (u v) (begin (set! v u) (+ x v))))
(* (f '1 '2) (g '3 '4)))))
'10 '11 '12)
(letrec ((f (lambda (x) (+ x 1)))
(g (lambda (y) (f (f y)))))
(+ (f 1) (g 1)))
(let ((y 3))
(letrec
((f (lambda (x) (if (zero? x) (g (+ x 1)) (f (- x y)))))
(g (lambda (x) (h (* x x))))
(h (lambda (x) x)))
(g 39)))
(letrec ((f (lambda (x) (+ x 1))) (g (lambda (y) (f (f y)))))
(set! f (lambda (x) (- x 1)))
(+ (f 1) (g 1)))
(letrec ([f (lambda () (+ a b))]
[a 17]
[b 35]
[h (cons (lambda () a) (lambda () b))])
(cons (f) (cons a (cons b (cons ((car h)) ((cdr h)))))))
(let ((v (make-vector 8)))
(vector-set! v 0 '())
(vector-set! v 1 (void))
(vector-set! v 2 #f)
(vector-set! v 3 #\a)
(vector-set! v 4 #\z)
(vector-set! v 5 #t)
(vector-set! v 6 2)
(vector-set! v 7 5)
(vector-ref v (vector-ref v 6)))
(let ([x 5] [th (let ((a 1)) (lambda () a))])
(letrec ([fact (lambda (n th)
(if (zero? n) (th) (* n (fact (- n 1) th))))])
(fact x th)))
(let ([negative? (lambda (n) (< n 0))])
(letrec
([fact (lambda (n)
(if (zero? n) 1 (* n (fact (- n 1)))))]
[call-fact (lambda (n)
(if (not (negative? n))
(fact n)
(- 0 (fact (- 0 n)))))])
(cons (call-fact 5) (call-fact -5))))
(letrec ([iota-fill! (lambda (v i n)
(if (not (= i n))
(begin
(vector-set! v i i)
(iota-fill! v (+ i 1) n))))])
(let ([n 4])
(let ([v (make-vector n)]) (iota-fill! v 0 n) v)))
; make-vector with non-constant operand and improper alignment
(let ([x 6])
(let ([v (make-vector x)])
(vector-set! v 0 3)
(vector-set! v 1 (cons (vector-ref v 0) 2))
(vector-set! v 2 (cons (vector-ref v 1) 2))
(vector-set! v 3 (cons (vector-ref v 2) 2))
(vector-set! v 4 (cons (vector-ref v 3) 2))
(vector-set! v 5 (cons (vector-ref v 4) 2))
(cons (pair? (vector-ref v 5)) (car (vector-ref v 4)))))
; nest some lambdas
(((((lambda (a)
(lambda (b)
(lambda (c)
(lambda (d)
(cons (cons a b) (cons c d))))))
33) 55) 77) 99)
; stress the register allocator
(let ((a 17))
(let ((f (lambda (x)
(let ((x1 (+ x 1)) (x2 (+ x 2)))
(let ((y1 (* x1 7)) (y2 (* x2 7)))
(let ((z1 (- y1 x1)) (z2 (- y2 x2)))
(let ((w1 (* z1 a)) (w2 (* z2 a)))
(let ([g (lambda (b)
(if (= b a)
(cons x1 (cons y1 (cons z1 '())))
(cons x2 (cons y2 (cons z2 '())))))]
[h (lambda (c)
(if (= c x) w1 w2))])
(if (if (= (* x x) (+ x x))
#t
(< x 0))
(cons (g 17) (g 16))
(cons (h x) (h (- x 0))))))))))))
(cons (f 2) (cons (f -1) (cons (f 3) '())))))
; printer
(letrec
([write
(lambda (x)
(let ([digits
(let ([v (make-vector 10)])
(vector-set! v 0 #\0)
(vector-set! v 1 #\1)
(vector-set! v 2 #\2)
(vector-set! v 3 #\3)
(vector-set! v 4 #\4)
(vector-set! v 5 #\5)
(vector-set! v 6 #\6)
(vector-set! v 7 #\7)
(vector-set! v 8 #\8)
(vector-set! v 9 #\9)
v)])
(letrec
([list->vector
(lambda (ls)
(let ([v (make-vector (length ls))])
(letrec
([loop
(lambda (ls i)
(if (null? ls)
v
(begin
(vector-set! v i (car ls))
(loop (cdr ls) (+ i 1)))))])
(loop ls 0))))]
[length
(lambda (ls)
(if (null? ls)
0
(add1 (length (cdr ls)))))]
[map
(lambda (p ls)
(if (null? ls)
'()
(cons (p (car ls))
(map p (cdr ls)))))]
[wr (lambda (x p)
(if (eq? x #f)
(cons #\# (cons #\f p))
(if (eq? x #t)
(cons #\# (cons #\t p))
(if (eq? x '())
(cons #\( (cons #\) p))
(if (eq? x (void))
(cons #\# (cons #\< (cons #\v
(cons #\o (cons #\i (cons #\d
(cons #\> p)))))))
(if (char? x)
(cons #\# (cons #\\
(if (eq? x #\newline)
(cons #\n (cons #\e (cons #\w
(cons #\l (cons #\i (cons #\n
(cons #\e p)))))))
(if (eq? x #\space)
(cons #\s (cons #\p
(cons #\a (cons #\c
(cons #\e p)))))
(if (eq? x #\tab)
(cons #\t (cons #\a
(cons #\b p)))
(cons x p))))))
(if (integer? x)
(if (< x 0)
(cons #\- (wrint (- 0 x) p))
(wrint x p))
(if (pair? x)
(cons #\( ; )
(letrec
([loop
(lambda (x)
(wr (car x)
(if (pair? (cdr x))
(cons #\space
(loop
(cdr x)))
(if
(null?
(cdr x))
;(
(cons #\) p)
(cons
#\space
(cons
#\.
(cons
#\space
(wr
(cdr
x)
;(
(cons
#\)
p)
))))
))))])
(loop x)))
(if (vector? x)
(cons #\# (cons #\( ; )
(let
([n (vector-length
x)])
(if (= n 0) ;(
(cons #\) p)
(letrec
([loop
(lambda (i)
(wr
(vector-ref
x i)
(if
(=
(+
i
1)
n)
;(
(cons
#\)
p)
(cons
#\space
(loop
(+
i
1))
)))
)])
(loop 0))))))
(if (procedure? x)
(cons #\# (cons #\<
(cons #\p (cons #\r
(cons #\o
(cons #\c
(cons #\e
(cons #\d
(cons #\u
(cons
#\r
(cons
#\e
(cons
#\>
p)
)))
))))))))
(cons #\# (cons #\<
(cons #\g (cons #\a
(cons #\r
(cons #\b
(cons #\a
(cons #\g
(cons #\e
(cons
#\>
p))))
)))))))))
)))))))]
[wrint (lambda (n p)
(if (< n 10)
(cons (vector-ref digits n) p)
(wrint
(quotient n 10)
(cons (vector-ref digits
(remainder n 10)) p))))]
[remainder (lambda (x y)
(let ([q (quotient x y)]) (- x (* y q))))]
[quotient (lambda (x y)
(if (< x 0)
(- 0 (quotient (- 0 x) y))
(if (< y 0)
(- 0 (quotient x (- 0 y)))
(letrec ([f (lambda (x a)
(if (< x y)
a
(f (- x y) (+ a 1))))])
(f x 0)))))])
(list->vector (map (lambda (x)
(char->integer x))
(wr x '()))))))])
(write
(let ([v1 (make-vector 4)] [v2 (make-vector 0)])
(vector-set! v1 0 #\a)
(vector-set! v1 1 #\space)
(vector-set! v1 2 #\newline)
(vector-set! v1 3 #\tab)
(cons (cons 0 (cons 4 (cons 2334 -98765)))
(cons (cons #t (cons #f (cons (void) (cons '() '()))))
(cons v1 (cons v2 write))))))))))

63
nanopass/tests/compiler-test.ss Normal file
View file

@ -0,0 +1,63 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests compiler-test)
(export test-one test-all run-main-tests run-final-tests run-all-tests)
(import (rnrs)
(tests compiler)
(tests test-driver)
(tests alltests))
(define run-final-tests
(case-lambda
[() (run-final-tests #t)]
[(emit?) (run-final-tests emit? #f)]
[(emit? noisy?) (tests final-tests) (test-all emit? noisy?)]))
(define run-main-tests
(case-lambda
[() (run-main-tests #t)]
[(emit?) (run-main-tests emit? #f)]
[(emit? noisy?) (tests main-tests) (test-all emit? noisy?)]))
(define run-all-tests
(case-lambda
[() (run-all-tests #t #f)]
[(emit?) (run-all-tests emit? #f)]
[(emit? noisy?) (run-main-tests emit? noisy?)
(run-final-tests emit? noisy?)]))
(passes
(define-passes
rename-vars/verify-legal
remove-implicit-begin
remove-unquoted-constant
remove-one-armed-if
uncover-settable
remove-impure-letrec
remove-set!
sanitize-binding
remove-anonymous-lambda
uncover-free
convert-closure
lift-letrec
explicit-closure
normalize-context
remove-complex-opera*
remove-anonymous-call
introduce-dummy-rp
remove-nonunary-let
return-of-set!
explicit-labels
;unparse-l18
;introduce-registers
;uncover-live
;uncover-conflict
;uncover-move
;assign-register
;rename-register
;assign-frame
;rename-frame
;flatten-program
;generate-code
)))

1456
nanopass/tests/compiler.ss Normal file
View file

File diff suppressed because it is too large Load diff

325
nanopass/tests/helpers.ss Normal file
View file

@ -0,0 +1,325 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests helpers)
(export compose disjoin any every choose reverse-filter fold reduce
constant? keyword? list-of-user-primitives list-of-system-primitives
user-primitive? system-primitive? primitive? predicate-primitive?
value-primitive? effect-primitive? effect-free-primitive? gen-label
reset-seed gen-symbol set? iota with-values
empty-set singleton-set
add-element member? empty? union intersection difference
variable? datum? list-index primapp sys-primapp app const-datum const
var quoted-const time printf system interpret pretty-print format set-cons
define-who)
(import (rnrs)
(tests implementation-helpers)
(nanopass helpers))
(define-syntax primapp
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax sys-primapp
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax app
(syntax-rules ()
[(_ expr expr* ...) (expr expr* ...)]))
(define-syntax const-datum
(syntax-rules ()
[(_ expr) (quote expr)]))
(define-syntax const
(syntax-rules ()
[(_ expr) expr]))
(define-syntax var
(syntax-rules ()
[(_ expr) expr]))
(define-syntax quoted-const
(syntax-rules ()
[(_ expr) (quote expr)]))
(define compose
(case-lambda
[() (lambda (x) x)]
[(f) f]
[(f . g*) (lambda (x) (f ((apply compose g*) x)))]))
(define disjoin
(case-lambda
[() (lambda (x) #f)]
[(p?) p?]
[(p? . q?*) (lambda (x)
(or (p? x) ((apply disjoin q?*) x)))]))
(define any
(lambda (pred? ls)
(let loop ([ls ls])
(cond
[(null? ls) #f]
[(pred? (car ls)) #t]
[else (loop (cdr ls))]))))
(define every
(lambda (pred? ls)
(let loop ([ls ls])
(cond
[(null? ls) #t]
[(pred? (car ls)) (loop (cdr ls))]
[else #f]))))
(define choose
(lambda (pred? ls)
(fold (lambda (elt tail)
(if (pred? elt)
(cons elt tail)
tail))
'()
ls)))
(define reverse-filter
(lambda (pred? ls)
(fold (lambda (elt tail)
(if (pred? elt)
tail
(cons elt tail)))
'()
ls)))
;; fold op base (cons a (cons b (cons c '()))) =
;; (op a (op b (op c base)))
(define fold
(lambda (op base ls)
(let recur ([ls ls])
(if (null? ls)
base
(op (car ls) (recur (cdr ls)))))))
;; reduce op base (cons a (cons b (cons c '())))
;; (op c (op b (op a base)))
(define reduce
(lambda (op base ls)
(let loop ([ls ls] [ans base])
(if (null? ls)
ans
(loop (cdr ls) (op (car ls) ans))))))
;;; General Scheme helpers for the compiler
(define constant?
(disjoin null? number? char? boolean? string?))
(define keyword?
(lambda (x)
(and (memq x '(quote set! if begin let letrec lambda)) #t)))
(define datum?
(lambda (x)
(or (constant? x)
(null? x)
(if (pair? x)
(and (datum? (car x)) (datum? (cdr x)))
(and (vector? x) (for-all datum? (vector->list x)))))))
(define variable? symbol?)
(define list-of-user-primitives
'(; not is a special case
(not 1 not)
; predicates
(< 2 test)
(<= 2 test)
(= 2 test)
(boolean? 1 test)
(char? 1 test)
(eq? 2 test)
(integer? 1 test)
(null? 1 test)
(pair? 1 test)
(procedure? 1 test)
(vector? 1 test)
(zero? 1 test)
; value-producing
(* 2 value)
(+ 2 value)
(- 2 value)
(add1 1 value)
(car 1 value)
(cdr 1 value)
(char->integer 1 value)
(cons 2 value)
(make-vector 1 value)
(quotient 2 value)
(remainder 2 value)
(sub1 1 value)
(vector -1 value)
(vector-length 1 value)
(vector-ref 2 value)
(void 0 value)
; side-effecting
(set-car! 2 effect)
(set-cdr! 2 effect)
(vector-set! 3 effect)))
(define list-of-system-primitives ; these are introduced later by the compiler
'(; value-producing
(closure-ref 2 value)
(make-closure 2 value)
(procedure-code 1 value)
; side-effecting
(closure-set! 3 effect)
(fref 1 value)
(fset! 2 effect)
(fincr! 1 effect)
(fdecr! 1 effect)
(href 2 value)
(hset! 3 effect)
(logand 2 value)
(sll 2 value)
(sra 2 value)))
(define user-primitive?
(lambda (x)
(and (assq x list-of-user-primitives) #t)))
(define system-primitive?
(lambda (x)
(and (assq x list-of-system-primitives) #t)))
(define primitive?
(lambda (x)
(or (user-primitive? x) (system-primitive? x))))
(define predicate-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'test))]
[else #f])))
(define value-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'value))]
[else #f])))
(define effect-primitive?
(lambda (x)
(cond
[(or (assq x list-of-user-primitives)
(assq x list-of-system-primitives)) =>
(lambda (a) (eq? (caddr a) 'effect))]
[else #f])))
(define effect-free-primitive?
(lambda (x)
(not (effect-primitive? x))))
(define gen-label
; at some point, gen-label should be redefined to emit
; assembler-friendly labels
(lambda (sym)
(string->symbol (format "~a%" sym))))
(define gen-symbol-seed 0)
(define reset-seed
(lambda ()
(set! gen-symbol-seed 0)))
(define gen-symbol
(lambda (sym)
(set! gen-symbol-seed (+ gen-symbol-seed 1))
(string->symbol (format "~a_~s" sym gen-symbol-seed))))
(define set?
(lambda (ls)
(or (null? ls)
(and (not (memq (car ls) (cdr ls))) (set? (cdr ls))))))
;;; ====================
;;; Extra syntax and helpers for multiple values
;;; Set abstraction
(define empty-set (lambda () '()))
(define singleton-set (lambda (elt) (list elt)))
(define add-element
(lambda (elt set)
(if (member? elt set)
set
(cons elt set))))
(define member? memq)
(define empty? null?)
(define set-cons
(lambda (a set)
(if (memq a set) set (cons a set))))
(define union
(case-lambda
[() (empty-set)]
[(set1 set2)
(cond
[(empty? set1) set2]
[(empty? set2) set1]
[(eq? set1 set2) set1]
[else (reduce (lambda (elt set)
(if (member? elt set2) set (cons elt set)))
set2
set1)])]
[(set1 . sets)
(if (null? sets)
set1
(union set1 (reduce union (empty-set) sets)))]))
(define intersection
(lambda (set1 . sets)
(cond
[(null? sets) set1]
[(any empty? sets) (empty-set)]
[else (choose
(lambda (elt)
(every (lambda (set) (member? elt set)) sets)) set1)])))
(define list-index
(lambda (a ls)
(cond
[(null? ls) -1]
[(eq? (car ls) a) 0]
[else (maybe-add1 (list-index a (cdr ls)))])))
(define maybe-add1
(lambda (n)
(if (= n -1) -1 (+ n 1))))
(define difference
(lambda (set1 . sets)
(let ((sets (reverse-filter empty? sets)))
(cond
[(null? sets) set1]
[else (reverse-filter (lambda (elt)
(any (lambda (set)
(member? elt set))
sets))
set1)])))))

6
nanopass/tests/implementation-helpers.chezscheme.sls Normal file
View file

@ -0,0 +1,6 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (only (chezscheme) time printf system interpret pretty-print format)))

19
nanopass/tests/implementation-helpers.ikarus.ss Normal file
View file

@ -0,0 +1,19 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (ikarus))
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rnrs) (rnrs mutable-pairs) (ikarus)))
(define interpret
(lambda (src)
(eval src (environment '(nanopass testing-environment))))))

23
nanopass/tests/implementation-helpers.ironscheme.sls Normal file
View file

@ -0,0 +1,23 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (ironscheme))
;; this seems to be only used for a pass not enabled. not sure how to use...
(define (system . args) #f)
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rnrs) (rnrs mutable-pairs) (ironscheme)))
(define interpret
(lambda (src)
(eval src (environment '(nanopass testing-environment))))))

6
nanopass/tests/implementation-helpers.ss Normal file
View file

@ -0,0 +1,6 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (only (scheme) time printf system interpret pretty-print format)))

40
nanopass/tests/implementation-helpers.vicare.sls Normal file
View file

@ -0,0 +1,40 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests implementation-helpers)
(export time printf system interpret pretty-print format)
(import (vicare))
(library
(nanopass testing-environment)
(export not < <= = boolean? char? eq? integer? null? pair? procedure?
vector? zero? * + - add1 car cdr char->integer cons make-vector
quotient remainder sub1 vector vector-length vector-ref void
set-car! set-cdr! vector-set! quote set! if begin lambda let
letrec)
(import (rename (rnrs) (set! vicare:set!) (if vicare:if))
(rnrs mutable-pairs)
(rename (only (vicare) void sub1 add1 remainder quotient) (void vicare:void)))
(define-syntax set!
(syntax-rules ()
[(_ x v) (call-with-values (lambda () (vicare:set! x v)) (case-lambda [() #!void] [(x) x]))]))
(define-syntax if
(syntax-rules ()
[(_ t c) (call-with-values (lambda () (vicare:if t c)) (case-lambda [() #!void] [(x) x]))]
[(_ t c a) (vicare:if t c a)]))
(define-syntax void
(syntax-rules ()
[(_) (call-with-values (lambda () (vicare:void)) (case-lambda [() #!void] [(x) x]))])))
(define interpret
(lambda (src)
;; work around for vicare's strange handling of the return value of primitives like set!,
;; which apparently returns no values.
(call-with-values (lambda () (eval src (environment '(nanopass testing-environment))))
(case-lambda
[() #!void]
[(x) x]))))
(define system
(lambda (arg)
(foreign-call "system" arg))))

102
nanopass/tests/new-compiler.ss Normal file
View file

@ -0,0 +1,102 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests new-compiler)
(export L0 parse-L0 unparse-L0)
(import (rnrs) (nanopass) (tests helpers))
#|
(compiler-passes '(
parse-scheme ;; conversion? simplification? verification.
convert-complex-datum ;; conversion/simplification
uncover-assigned ;; analysis
purify-letrec ;; conversion/simplification
convert-assignments ;; conversion
optimize-direct-call ;; optimization
remove-anonymous-lambda ;; conversion
sanitize-binding-forms ;; conversion/simplification
uncover-free ;; analysis
convert-closures ;; conversion
optimize-known-call ;; optimization
analyze-closure-size ;; analysis
uncover-well-known ;; analysis (for optimization)
optimize-free ;; optimization
optimize-self-reference ;; optimization
analyze-closure-size ;; analysis
introduce-procedure-primitives ;; conversion
lift-letrec ;; conversion
normalize-context ;; conversion
specify-representation ;; conversion
uncover-locals ;; analysis
remove-let ;; conversion
verify-uil ;; verification
remove-complex-opera* ;; conversion
flatten-set! ;; conversion
impose-calling-conventions ;; conversion
expose-allocation-pointer ;; conversion
uncover-frame-conflict ;; conversion
pre-assign-frame ;;
assign-new-frame
(iterate
finalize-frame-locations
select-instructions
uncover-register-conflict
assign-registers
(break when everybody-home?)
assign-frame)
discard-call-live
finalize-locations
expose-frame-var
expose-memory-operands
expose-basic-blocks
#;optimize-jumps
flatten-program
generate-x86-64
))
|#
(define vector-for-all
(lambda (p? x)
(let loop ([n (fx- (vector-length x) 1)])
(cond
[(fx<? n 0) #t]
[(not (p? (vector-ref x n))) #f]
[else (loop (fx- n 1))]))))
(define target-fixnum?
(lambda (x)
(and (integer? x) (exact? x)
(<= (- (ash 1 60)) x (- (ash 1 60) 1)))))
(define constant?
(lambda (x)
(or (eq? x #t) (eq? x #f) (eq? x '()) (target-fixnum? x))))
(define scheme-object?
(lambda (x)
(or (constant? x)
(and (pair? x) (scheme-object? (car x)) (scheme-object? (cdr x)))
(and (vector? x) (vector-for-all scheme-object? x)))))
(define-language L0
(terminals
(constant (c))
(scheme-object (d))
(variable (x))
(primitive (pr)))
(Expr (e body)
c
x
(quote d)
(if e0 e1)
(if e0 e1 e2)
(and e* ...)
(or e* ...)
(begin e* ... e)
(lambda (x* ...) body body* ...)
(let ([x* e*] ...) body body* ...)
(letrec ([x* e*] ...) body body* ...)
(set! x e)
(pr e* ...)
(e0 e* ...)))
)

281
nanopass/tests/synforms.ss Normal file
View file

@ -0,0 +1,281 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
;;; AWK - TODO - Once the meta-parser can handle language passes that match
;;; a single variable.
;;; FIXME - For Ikarus, I needed to use "dots" instead of the ".."
;;; because Ikarus sees .. as a syntax error, even when it is
;;; exported as an auxiliary keyword.
;;; Time-stamp: <2000-01-10 12:29:38 kemillik>
;;; (time-stamp generated by emacs: Type M-x time-stamp anywhere to update)
;;; syncase is a pattern matcher where patterns are quoted or
;;; quasiquoted expressions, or symbols. Unquoted symbols denote
;;; pattern variables. All quoted things must match precisely.
;;; Also, there is a symbol ".." that may be used to allow repetitions
;;; of the preceeding pattern. Any pattern variables within are bound
;;; to a list of matches. ".." may be nested.
;;; Below is the canonical example of "let"
;;; [`(let ([,var ,rhs] ..) ,body0 ,body1 ..)
;;; (guard (for-all symbol? var) (no-duplicates? var))
;;; `((lambda ,var ,body0 ,@body1) ,@rhs)]
;;; For the pattern to match, the optional guard requires its
;;; arguments to be true. The guard also uses the pattern
;;; variables.
;;; We have added three obvious new forms: synlambda, synlet, and
;;; synlet*. Finally, we have added a very useful operation,
;;; make-double-collector-over-list, whose description follows from the
;;; very simple code below.
;;; Here are some descriptive examples of each of the new special forms.
;;;> (define foo
;;; (synlambda `((if ,exp0 ,exp1) ,env)
;;; (guard (number? exp1))
;;; `(,env (if ,exp0 ,exp1 0))))
;;;> (foo '(if 1 2) 'anenv)
;;;(anenv (if 1 2 0))
;;;> (synlet ([`(if ,exp0 ,exp1)
;;; (guard (number? exp0))
;;; '(if 0 1)])
;;; `(if ,exp1, exp0))
;;;(if 1 0)
;;;> (synlet ([`(if ,x ,y ,z) '(if 1 2 3)]
;;; [`(if ,a then ,b else ,c) '(if 1 then 2 else 3)]
;;; [`(when ,u ,w) (guard (number? u) (number? w) (= u w))
;;; '(when 1 1)])
;;; (list x y z a b c a b))
;;; (1 2 3 1 2 3 1 2)
;;;> (synlet* ([`(if ,exp0 ,exp1) (guard (number? exp0)) '(if 0 1)]
;;; [`(if ,x ,y ,exp2) `(if ,exp0 ,exp1 5)])
;;; `(if ,exp0 ,y ,exp2))
;;;(if 0 1 5)
(library (tests synforms)
(export syncase)
(import (rnrs))
(define-syntax syncase
(syntax-rules ()
[(_ Exp (Clause ...) ...)
(let ([x Exp])
(call/cc
(lambda (succeed)
(pm:c start x succeed Clause ...)
...
(error 'syncase "No match for ~s" x))))]))
(define-syntax pm:c
(syntax-rules (guard start finish)
[(pm:c start V Succ Pattern (guard Exp ...) Body0 Body ...)
(pm:parse start Pattern
(pm:c finish V
(when (and Exp ...)
(Succ (begin Body0 Body ...)))))]
[(pm:c finish V Body Pattern UsedFormals)
(pm:find-dup UsedFormals
(cont (Dup)
(pm:error "Duplicate patvar ~s in pattern ~s" Dup Pattern))
(cont () (pm V Pattern Body)))]
[(_ start V Succ Pattern Body0 Body ...)
(pm:c start V Succ Pattern (guard) Body0 Body ...)]
[(_ start V Succ Pattern)
(pm:error "Missing body for pattern ~s" Pattern)]))
(define-syntax pm:parse ;; returns parsed thing + used formals
(syntax-rules (dots quasiquote quote unquote start)
[(pm:parse start () K) (pm:ak K (null) ())]
[(pm:parse start (unquote X) K) (pm:ak K (formal X) (X))]
[(pm:parse start (A . D) K) (pm:parseqq start (A . D) K)]
[(pm:parse start X K) (pm:ak K (keyword X) ())]))
(define-syntax pm:parseqq;; returns parsed thing + used formals
(lambda (x)
(syntax-case x (unquote start dothead dottail dottemps pairhead pairtail)
[(pm:parseqq start (unquote ()) K) #'(pm:error "Bad variable: ~s" ())]
[(pm:parseqq start (unquote (quasiquote X)) K) #'(pm:parseqq start X K)]
[(pm:parseqq start (unquote (X . Y)) K)
#'(pm:error "Bad variable: ~s" (X . Y))]
[(pm:parseqq start (unquote #(X ...)) K)
#'(pm:error "Bad variable: ~s" #(X ...))]
[(pm:parseqq start (unquote X) K) #'(pm:ak K (formal X) (X))]
[(pm:parseqq start (X dots . Y) K)
(eq? (syntax->datum #'dots) '...)
#'(pm:parseqq start X (pm:parseqq dothead Y K))]
[(pm:parseqq dothead Y K Xpat Xformals)
#'(pm:parseqq^ start Y () ()
(pm:parseqq dottail Xpat Xformals K))]
[(pm:parseqq dottail Xpat Xformals K Yrevpat Yformals)
#'(pm:gen-temps Xformals ()
(pm:parseqq dottemps Xpat Yrevpat Xformals Yformals K))]
[(pm:parseqq dottemps Xpat Yrevpat (Xformal ...) (Yformal ...) K Xtemps)
#'(pm:ak K (dots (Xformal ...) Xtemps Xpat Yrevpat)
(Xformal ... Yformal ...))]
[(pm:parseqq start (X . Y) K)
#'(pm:parseqq start X (pm:parseqq pairhead Y K))]
[(pm:parseqq pairhead Y K Xpat Xformals)
#'(pm:parseqq start Y (pm:parseqq pairtail Xpat Xformals K))]
[(pm:parseqq pairtail Xpat (Xformal ...) K Ypat (Yformal ...))
#'(pm:ak K (pair Xpat Ypat) (Xformal ... Yformal ...))]
[(pm:parseqq start X K) #'(pm:ak K (keyword X) ())])))
(define-syntax pm:parseqq^;; returns list-of parsed thing + used formals
(syntax-rules (dots start pairhead)
[(pm:parseqq^ start () Acc Used K) (pm:ak K Acc ())]
[(pm:parseqq^ start (dots . Y) Acc Used K)
(pm:error "Illegal continuation of list pattern beyond dots: ~s" Y)]
[(pm:parseqq^ start (X . Y) Acc Used K)
(pm:parseqq start X (pm:parseqq^ pairhead Y Acc Used K))]
[(pm:parseqq^ pairhead Y Acc (Used ...) K Xpat (Xformal ...))
(pm:parseqq^ start Y (Xpat . Acc) (Used ... Xformal ...) K)]
[(pm:parseqq^ start X Acc Used K) (pm:error "Bad pattern ~s" X)]))
(define-syntax pm
(syntax-rules (keyword formal dots null pair)
[(pm V (keyword K) Body) (when (eqv? V 'K) Body)]
[(pm V (formal F) Body) (let ((F V)) Body)]
[(pm V (dots Dformals DTemps DPat (PostPat ...)) Body)
(when (list? V)
(let ((rev (reverse V)))
(pm:help rev (PostPat ...) Dformals DTemps DPat Body)))]
[(pm V (null) Body) (when (null? V) Body)]
[(pm V (pair P0 P1) Body)
(when (pair? V)
(let ((X (car V)) (Y (cdr V)))
(pm X P0 (pm Y P1 Body))))]))
(define-syntax pm:help
(syntax-rules ()
[(pm:help V () (DFormal ...) (DTemp ...) DPat Body)
(let f ((ls V) (DTemp '()) ...)
(if (null? ls)
(let ((DFormal DTemp) ...) Body)
(let ((X (car ls)) (Y (cdr ls)))
(pm X DPat
(f Y (cons DFormal DTemp) ...)))))]
[(pm:help V (Post0 PostPat ...) DFormals DTemps DPat Body)
(when (pair? V)
(let ((X (car V)) (Y (cdr V)))
(pm X Post0
(pm:help Y (PostPat ...) DFormals DTemps DPat Body))))]))
(define-syntax pm:error
(syntax-rules ()
[(pm:error X ...) (error 'syncase 'X ...)]))
(define-syntax pm:eq?
(syntax-rules ()
[(_ A B SK FK) ; b should be an identifier
(let-syntax ([f (syntax-rules (B)
[(f B _SK _FK) (pm:ak _SK)]
[(f nonB _SK _FK) (pm:ak _FK)])])
(f A SK FK))]))
(define-syntax pm:member?
(syntax-rules ()
[(pm:member? A () SK FK) (pm:ak FK)]
[(pm:member? A (Id0 . Ids) SK FK)
(pm:eq? A Id0 SK (cont () (pm:member? A Ids SK FK)))]))
(define-syntax pm:find-dup
(syntax-rules ()
[(pm:find-dup () SK FK) (pm:ak FK)]
[(pm:find-dup (X . Y) SK FK)
(pm:member? X Y
(cont () (pm:ak SK X)) (cont () (pm:find-dup Y SK FK)))]))
(define-syntax pm:gen-temps
(syntax-rules ()
[(_ () Acc K) (pm:ak K Acc)]
[(_ (X . Y) Acc K) (pm:gen-temps Y (temp . Acc) K)]))
;;; ------------------------------
;;; Continuation representation and stuff
(define-syntax cont ; broken for non-nullary case
(syntax-rules ()
[(_ () Body) Body]
[(_ (Var ...) Body Exp ...)
(let-syntax ([f (syntax-rules ()
[(_ Var ...) Body])])
(f Exp ...))]))
(define-syntax pm:ak
(syntax-rules ()
[(_ (X Y ...) Z ...) (X Y ... Z ...)]))
;;; ------------------------------
;;; tests
;(define exp0
; '(syncase '((a) (b) (c d))
; ((,zz ,ww) ((,zz .. ,ww) ..)
; zz)))
;(define test
; (lambda (x)
; (pretty-print x)
; (pretty-print (eval x))
; (newline)))
;
;(define test0 (lambda () (test exp0)))
;;; There are three additional special forms, which should be obvious.
(define-syntax synlambda
(syntax-rules (guard)
[(_ pat (guard g ...) body0 body1 ...)
(lambda (x)
(syncase x
[pat (guard g ...) (begin body0 body1 ...)]))]
[(_ pat body0 body1 ...)
(lambda (x)
(syncase x
[pat (begin body0 body1 ...)]))]))
(define-syntax synlet
(syntax-rules (guard)
[(_ ([pat (guard g) rhs] ...) body0 body1 ...)
((synlambda `(,pat ...)
(guard (and g ...)) body0 body1 ...) `(,rhs ...))]
[(_ ([pat rhs] ...) body0 body1 ...)
((synlambda `(,pat ...) body0 body1 ...) `(,rhs ...))]
[(_ stuff ...) (synlet-all-guarded () stuff ...)]))
(define-syntax synlet-all-guarded
(syntax-rules (guard)
[(_ (x ...) () body0 body1 ...) (synlet (x ...) body0 body1 ...)]
[(_ (x ...) ([pat (guard g0 g1 g2 ...) rhs] decl ...) body0 body1 ...)
(synlet-all-guarded (x ... [pat (guard (and g0 g1 g2 ...)) rhs])
(decl ...) body0 body1 ...)]
[(_ (x ...) ([pat rhs] decl ...) body0 body1 ...)
(synlet-all-guarded (x ... [pat (guard #t) rhs])
(decl ...) body0 body1 ...)]
[(_ (x ...) ([pat] decl ...) body0 body1 ...)
(pm:error "synlet missing right-hand-side for pattern: ~s" pat)]
[(_ () (decl ...)) (pm:error "synlet missing body")]))
(define-syntax synlet*
(syntax-rules ()
[(_ (dec) body0 body1 ...) (synlet (dec) body0 body1 ...)]
[(_ (dec0 decl ...) body0 body1 ...)
(synlet (dec0) (synlet* (decl ...) body0 body1 ...))]))
(define make-double-collector-over-list
(lambda (constructor1 base1 constructor2 base2)
(letrec ((loop42 (lambda args
(if (not (= (length args) 2))
(error 'syncase "Invalid rhs expression"))
(let ([f (car args)] [arg (cadr args)])
(cond
[(null? arg) `(,base1 ,base2)]
[else
(synlet ([`(,x ,y) (f (car arg))]
[`(,x* ,y*) (loop42 f (cdr arg))])
`(,(constructor1 x x*)
,(constructor2 y y*)))])))))
loop42))))

200
nanopass/tests/test-driver.ss Normal file
View file

@ -0,0 +1,200 @@
;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(library (tests test-driver)
(export define-passes pass-names passes tracer test-one test-all tests
print-file)
(import (rnrs) (tests helpers))
(define subst
(lambda (new old tree)
(cond
[(null? tree) '()]
[(equal? tree old) new]
[(pair? tree) `(,(subst new old (car tree)) .
,(subst new old (cdr tree)))]
[else tree])))
(define void (lambda () (if #f #f)))
(define-syntax define-passes
(syntax-rules ()
[(_ p1 p2 ...) (list '(p1 p2 ...) (list p1 p2 ...))]))
(define passes
(let ([pass-list '()])
(case-lambda
[() pass-list]
[(x) (set! pass-list x)])))
(define-syntax pass-names
(identifier-syntax (let ([passes (passes)])
(if (null? passes) '() (car passes)))))
(define tests
(let ([test-list '()])
(case-lambda
[() test-list]
[(x) (set! test-list x)])))
(define tracer
(let ([trace-list '()])
(case-lambda
[() trace-list]
[(x)
(set! trace-list
(cond
[(eq? x #t) pass-names]
[(eq? x #f) '()]
[(and (symbol? x) (memq x pass-names)) (list x)]
[(and (list? x) (for-all (lambda (x) (memq x pass-names)) x)) x]
[else (error 'tracer (format "invalid argument ~s" x))]))])))
(define test-all
(case-lambda
[() (test-all #t #f #f)]
[(emit?) (test-all emit? #f #f)]
[(emit? print-expr?) (test-all emit? print-expr? #f)]
[(emit? print-expr? check-eval?)
(for-each
(lambda (x)
(when print-expr? (pretty-print x))
(unless (test-one x emit?)
(error 'test-all "test failed")))
(tests))]))
(define print-file
(lambda (path)
(with-input-from-file path
(letrec ([f (lambda ()
(unless (eof-object? (peek-char))
(write-char (read-char))
(f)))])
f))))
(define test-one
(case-lambda
[(original-input-expr) (test-one original-input-expr #t)]
[(original-input-expr emit?)
(let ([answer (interpret original-input-expr)])
(define-syntax on-error
(syntax-rules ()
[(_ e0 e1 e2 ...)
(guard (e [else e0 (raise e)])
e1 e2 ...)]))
#;
(define check-eval
(lambda (pass-name input-expr output-expr)
(on-error
(begin
(printf "~s input:~%" pass-name)
(pretty-print input-expr)
(printf "========~%~s output:~%" pass-name)
(pretty-print output-expr))
(let ([t (interpret output-exr)])
(unless (equal? t answer)
(error pass-name
(format "answer is ~s, should have been ~s" t answer)))
(let ([t (parameterize ([run-cp0 (lambda (cp0 x) x)])
(interpret output-expr))])
(unless (equal? t answer)
(error pass-name "answer is ~s, should have been ~s"
t answer)))))))
(define check-eval
(lambda (pass-name input-expr output-expr)
(void)))
(define run
(lambda (input-expr pass-names pass-procs)
(if (null? pass-names)
input-expr
(let ([pass-name (car pass-names)])
(when (memq pass-name (tracer)) (printf "~%~s:~%" pass-name))
(let ([pass (car pass-procs)])
(let ([output-expr
(on-error
(begin
(printf "~s input:~%" pass-name)
(pretty-print input-expr))
(pass input-expr))])
(check-eval pass-name input-expr output-expr)
(when (memq pass-name (tracer))
(pretty-print output-expr))
(run output-expr (cdr pass-names) (cdr pass-procs))))))))
;; AWK - TODO - need to come up with more elegant handling of this
;; since looking up generate-code for each test is
;; pretty hackish. Maybe passes could handle this as
;; well?
(define generate-code
(lambda (expr)
(let ([passes (passes)])
(if (null? passes)
(error 'generate-code "No passes defined")
(let ([proc (let l ([names (car passes)]
[procs (cadr passes)])
(cond
[(null? names)
(error 'generate-code
"No generate-code pass defined")]
[(eq? 'generate-code (car names)) (car procs)]
[else (l (cdr names) (cdr procs))]))])
(proc expr))))))
(define run-code
(lambda (input-expr)
(define asm-file "t1.s")
(define err-file "t1.err")
(define out-file "t1.out")
(when (memq 'generate-code (tracer)) (printf "~%generate-code:~%"))
(on-error
(begin
(printf "generate-code input:~%")
(pretty-print input-expr))
(when (file-exists? asm-file) (delete-file asm-file))
(with-output-to-file asm-file
(lambda ()
(printf "/* ~%")
(pretty-print original-input-expr)
(printf "*/~%~%")
(print-file "canned.s")
(newline)
(generate-code input-expr))))
(on-error
(begin
(printf "generate-code input:~%")
(pretty-print input-expr)
(printf "========~%generate-code output:~%")
(print-file asm-file)
(printf "========~%")
(print-file err-file))
(let ([t (assemble-and-run asm-file err-file out-file)])
(unless (equal? t answer)
(error 'generate-code
(format "answer is ~s, should have been ~s"
t answer)))))
(when (memq 'generate-code (tracer)) (print-file asm-file))))
(reset-seed)
(let ([expr (run original-input-expr (car (passes)) (cadr (passes)))])
(when (and emit? (memq 'generate-code pass-names))
(run-code expr))
#t))]))
(define assemble-and-run
(lambda (asm-file err-file out-file)
(define shell
(lambda (s . args)
(system (apply format s args))))
(unless
(= 0 (shell "cc -o run startup.c ~a > ~a 2>&1" asm-file err-file))
(error 'generate-program "build error(s)"))
(let ([status (shell "exec ./run > ~a 2>&1" out-file)])
(shell "cat ~a >> ~a" out-file err-file)
(unless (= status 0)
(error 'generate-program "run error(s)")))
; replace #<void> with "#<void>" to make it something the reader can
; handle, then substitute void for "#<void>"
(shell "sed -e 's/#<void>/\"#<void>\"/g' < ~a > ~a.tmp"
out-file out-file)
(let ([ip (open-input-file (format "~a.tmp" out-file))])
(let ([x (subst (void) "#<void>" (read ip))])
(close-input-port ip)
x)))))

9
nanopass/tests/unit-test-helpers-implementation.chezscheme.sls Normal file
View file

@ -0,0 +1,9 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (chezscheme))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (parameterize ([print-level 3] [print-length 6]) (format args ...))])))

29
nanopass/tests/unit-test-helpers-implementation.ikarus.sls Normal file
View file

@ -0,0 +1,29 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (ikarus))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)])))

36
nanopass/tests/unit-test-helpers-implementation.ironscheme.sls Normal file
View file

@ -0,0 +1,36 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (ironscheme))
;; easy enough to define ;p
(define (with-output-to-string thunk)
(let-values (((p g) (open-string-output-port)))
(parameterize ([current-output-port p])
(thunk)
(g))))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)])))

32
nanopass/tests/unit-test-helpers-implementation.vicare.sls Normal file
View file

@ -0,0 +1,32 @@
;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers-implementation)
(export with-output-to-string display-condition format-error-message)
(import (vicare))
(define display-condition
(case-lambda
[(c) (display-condition c (current-output-port))]
[(c op)
(display
(format "~a~a~a~a~a"
(if (warning? c) "Warning" "Exception")
(if (who-condition? c) (format " in ~s" (condition-who c)) "")
(if (message-condition? c) (format ": ~a" (condition-message c)) "")
(if (and (irritants-condition? c) (not (null? (condition-irritants c))))
(format " with irritants ~s" (condition-irritants c))
"")
(if (syntax-violation? c)
(if (syntax-violation-subform c)
(format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
(format "~s" (syntax-violation-form c)))
""))
op)]))
(define-syntax format-error-message
(syntax-rules ()
[(_ args ...) (format args ...)]))
;; needed to get an r6rs script to print with vicare
(current-output-port (current-error-port)))

124
nanopass/tests/unit-test-helpers.ss Normal file
View file

@ -0,0 +1,124 @@
;;; Copyright (c) 2000-2018 Andrew W. Keep, R. Kent Dybvig
;;; See the accompanying file Copyright for details
(library (tests unit-test-helpers)
(export test-suite test assert-equal? assert-error with-output-to-string format-error-message)
(import (rnrs) (tests unit-test-helpers-implementation) (only (nanopass helpers) errorf))
(define-syntax test-suite
(lambda (x)
(define name->run-name
(lambda (name)
(datum->syntax name
(string->symbol
(string-append "run-" (symbol->string (syntax->datum name)))))))
(syntax-case x ()
[(_ name test test* ...)
(with-syntax ([run (name->run-name #'name)])
#'(define run
(lambda ()
(display "Running ")
(write (quote name))
(display " test suite...\n")
(let f ([tests (list (lambda () test) (lambda () test*) ...)]
[successes 0] [failures 0] [exceptions 0])
(if (null? tests)
(begin
(display "Ran ")
(write (+ successes failures exceptions))
(display " tests with ")
(write successes)
(display " successes, ")
(write failures)
(display " failures, and ")
(write exceptions)
(display " exceptions\n")
(and (= failures 0) (= exceptions 0)))
(guard (e [else
(display " caught expection... ")
(display-condition e)
(newline)
(f (cdr tests) successes failures
(+ exceptions 1))])
(let ([result ((car tests))])
(write result)
(newline)
(if result
(f (cdr tests) (+ successes 1) failures
exceptions)
(f (cdr tests) successes (+ failures 1)
exceptions)))))))))])))
(define-syntax test
(syntax-rules ()
[(_ name assertion assertion* ...)
(begin
(display " Testing ")
(write (quote name))
(display " ...")
(and assertion assertion* ...))]))
;; extended to cover record equality, but not doing the union-find
;; equality we should be doing.
(define stupid-extended-equal?
(lambda (x y)
(or (equal? x y)
(and (record? x)
(record? y)
(record=? x y)))))
(define record-type-accessors
(lambda (rtd)
(let loop ([i (vector-length (record-type-field-names rtd))] [ls '()])
(if (fx=? i 0)
ls
(let ([i (fx- i 1)])
(loop i (cons (record-accessor rtd i) ls)))))))
(define record=?
(lambda (x y)
(let ([rtd (record-rtd x)])
(and (eq? rtd (record-rtd y))
(let loop ([rtd rtd])
(or (eq? rtd #f)
(and (for-all (lambda (ac) (stupid-extended-equal? (ac x) (ac y))) (record-type-accessors rtd))
(loop (record-type-parent rtd)))))))))
(define-syntax assert-equal?
(syntax-rules ()
[(_ expected actual)
(or (stupid-extended-equal? expected actual)
(begin
(newline)
(display "!!! ")
(write actual)
(display " does not match expected: ")
(write expected)
(newline)
#f))]))
(define-syntax assert-error
(syntax-rules ()
[(_ ?msg ?expr)
(let ([msg ?msg])
(guard (e [else
(let ([e-msg (with-output-to-string
(lambda ()
(display-condition e)))])
(or (string=? msg e-msg)
(begin
(newline)
(display "!!! expected error message ")
(write msg)
(display " does not match ")
(write e-msg)
(newline)
#f)))])
(let ([t ?expr])
(newline)
(display "!!! expected error with message ")
(write msg)
(display " but got result ")
(write t)
(newline)
#f)))])))

1105
nanopass/tests/unit-tests.ss Normal file
View file

File diff suppressed because it is too large Load diff