201 lines
7.7 KiB
Scheme
201 lines
7.7 KiB
Scheme
|
;;; 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)))))
|
||
|
|
|