1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
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)))))
|
