-
Notifications
You must be signed in to change notification settings - Fork 3
/
tests.rkt
186 lines (163 loc) · 7.96 KB
/
tests.rkt
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
#lang racket
;; Testing apparatus modified from assignments
;; Its pretty bad, i hacked it to work for this... so yeah
(require (only-in "src/racket/utils.rkt"
test-desugar
test-alphatize
test-anf-convert
test-closure-convert
eval-proc
read-begin
eval-top-level))
(require (only-in "src/racket/desugar.rkt" desugar))
(require (only-in "src/racket/alphatize.rkt" alphatize))
(require (only-in "src/racket/assignment-convert.rkt" assignment-convert))
(require (only-in "src/racket/ssa-anf.rkt" anf-convert))
(require (only-in "src/racket/ssa-closure-convert.rkt" closure-convert))
(require (only-in "src/racket/ssa-llvm-segmented.rkt" llvm-convert))
(require (only-in "compiler.rkt" gen-build-file scm->exe llvm->exe))
; compiles and interprets the code and calls the callback
; giving it the compiled and interpreted results as strings (in that order).
(define (compile-and-interpret code-str fin)
; get value when we interpret the input
(define interpreted-input (read-begin (open-input-string code-str)))
(define interpreted-eval (eval-top-level interpreted-input))
(define interpreted-value (~a interpreted-eval))
; get value when we compile and execute the input
(define compiler-input (open-input-string code-str))
(define generated-name (gensym 'generated))
(define header-name (gen-build-file generated-name ".ll"))
(define exe-name (gen-build-file generated-name ".x"))
(scm->exe (open-input-string code-str) exe-name)
(define compiled-value
(string-normalize-spaces (with-output-to-string (λ () (system (format "./~a" exe-name))))))
; call the callback with the differente values
(fin compiled-value interpreted-value))
;; Takes closure converted proc-exp?
(define (test-llvm-convert llvm-convert prog)
(define interpreted-val (~a (eval-proc prog)))
;(pretty-display `(proc-val ,interpreted-val))
(define llvm (llvm-convert prog))
(define exe-name (gen-build-file (gensym 'testllvm) ".x"))
(llvm->exe llvm exe-name)
; If this function gets any more complicated we should refactor and
; share code with the compile-and-run function.
(define compiled-val
(string-normalize-spaces (with-output-to-string (λ () (system (format "./~a" exe-name))))))
(define success (equal? interpreted-val compiled-val))
(unless success (displayln (format "llvm: '~a'\ninterpreted: '~a'" compiled-val interpreted-val)))
success)
; Single test creation.
(define (new-failing-test test-file-path)
(lambda ()
(define didnt-fail-tag (gensym 'did-not-fail))
(define file-contents (file->string test-file-path))
(define guarded-code `(guard (_ [',didnt-fail-tag #t] [else #f])
,file-contents (raise ',didnt-fail-tag)))
(define guarded-string (~s guarded-code))
(compile-and-interpret
guarded-string
(λ (c i)
(define success (and (equal? "#t" c) (equal? "#t" i)))
(unless success (displayln (format "llvm:~a\ntop-level:~a" c i)))
success))))
(define (new-passing-test test-file-path)
(lambda ()
(compile-and-interpret
(file->string test-file-path)
(λ (c i)
; convert the interpreted output to a string to compare.
(define success (equal? c i))
(unless success (displayln (format "llvm:~a\ntop-level:~a" c i)))
success))))
; TODO: move testing functions from utils.rkt to here?
; Or maybe move the testing functionality into the tests/ folder,
; and this just be the API?
(define (new-phase-test test-file-path f)
(lambda ()
(define test-contents (read (open-input-string (file->string test-file-path))))
(with-handlers ([exn:fail? (λ (ex) (displayln ex) #f)])
(f test-contents))))
(define (new-desugar-test p) (new-phase-test p (λ (c) (test-desugar desugar c))))
(define (new-alphatize-test p)
(new-phase-test p (λ (c) (test-alphatize assignment-convert alphatize c))))
(define (new-anf-test p) (new-phase-test p (λ (c) (test-anf-convert anf-convert c))))
(define (new-clo-test p) (new-phase-test p (λ (c) (test-closure-convert closure-convert c))))
(define (new-llvm-test p) (new-phase-test p (λ (c) (test-llvm-convert llvm-convert c))))
;; (define (new-llvm-test p) (new-phase-test p (λ (c) (test-llvm-convert llvm-convert c))))
; test suite creation
(define (get-tests-at testsloc filetype)
(map (λ (p) (string->path (string-append testsloc (path->string p))))
(filter (λ (p) (equal? (last (string-split (path->string p) ".")) filetype))
(directory-list testsloc))))
; makes a suite of tests that can each be executed.
; prepends each test name with the prefix.
(define (make-suite prefix make-test test-list)
; takes a path like /a/b/c/d.scm and returns 'd'
(define (extract-filename p)
(last (string-split (string-join (drop-right (string-split (path->string p) ".") 1) ".") "/")))
(map (λ (p) (list (string-append prefix (extract-filename p)) (make-test p))) test-list))
(define passing-tests (make-suite "passing-" new-passing-test
(get-tests-at "tests/passing/" "sinscm")))
(define failing-tests (make-suite "failing-" new-failing-test
(get-tests-at "tests/failing/" "sinscm")))
(define desugar-tests (make-suite "desugar-" new-desugar-test
(get-tests-at "tests/phases/desugar/" "scm")))
(define alphatize-tests (make-suite "alpha-" new-alphatize-test
(get-tests-at "tests/phases/alphatize/" "ir")))
(define anf-tests (make-suite "anf-" new-anf-test
(get-tests-at "tests/phases/anf/" "alpha")))
(define clo-tests (make-suite "clo-" new-clo-test
(get-tests-at "tests/phases/clo/" "anf")))
(define llvm-tests (make-suite "llvm-" new-llvm-test
(get-tests-at "tests/phases/llvm/" "proc")))
;; (define llvm-tests (make-suite "llvm-" new-llvm-test
;; (get-tests-at "tests/phases/llvm/" "proc")))
(define (run-single testcase)
(match-define (list test-name exec) testcase)
(define exec-result
(with-handlers ([exn:fail? (lambda (ex) (displayln ex) #f)]) (exec)))
(define passed (eq? exec-result #t))
(displayln (format "Test '~a' ~a." test-name
(if passed "passed" "failed")))
passed)
(define (run-suite suite)
(define failed-tests
(foldl (λ (testcase fails)
(if (run-single testcase) fails (cons (car testcase) fails)))
'() suite))
(displayln (format "Score on tests: ~a/~a"
(- (length suite) (length failed-tests))
(length suite)))
(unless (empty? failed-tests)
(displayln (format "Failed: [~a]" (string-join failed-tests ", ")))))
(define all-tests (append passing-tests failing-tests
desugar-tests alphatize-tests
anf-tests
clo-tests llvm-tests))
(define (run-test/internal is-repl . args)
;; Run all tests, a specific test or suite, or print the available tests
(match args
[(list "all") (run-suite all-tests)]
[(list "passing") (run-suite passing-tests)]
[(list "failing") (run-suite failing-tests)]
[(list "desugar") (run-suite desugar-tests)]
[(list "alpha") (run-suite alphatize-tests)]
[(list "anf") (run-suite anf-tests)]
[(list "clo") (run-suite clo-tests)]
[(list "llvm") (run-suite llvm-tests)]
[(list test-name)
#:when (assoc test-name all-tests)
(define passed (run-single (assoc test-name all-tests)))
(unless is-repl
(exit (if passed 0 1)))]
[(list unknown)
(displayln (string-append "unknown test name: '" unknown "'"))]
['()
(displayln "Available tests: ")
(displayln (string-join (map car all-tests) ", "))]))
(define run-test
(curry run-test/internal #t))
(define r run-test) ; for easier repl usage
(apply run-test/internal
(cons #f (vector->list (current-command-line-arguments))))