105 lines
3.9 KiB
Scheme
105 lines
3.9 KiB
Scheme
(import (chicken bitwise))
|
|
(import (chicken file))
|
|
(import (chicken io))
|
|
(import (chicken process))
|
|
|
|
(define tests-ran 0)
|
|
(define tests-passed 0)
|
|
(define tests-failed 0)
|
|
|
|
(define (create-rom prog-text)
|
|
(let* ((tal-path (create-temporary-file ".tal"))
|
|
(rom-path (string-append tal-path ".rom"))
|
|
(asm-cmd (string-append "uxnasm " tal-path " " rom-path ">/dev/null"))
|
|
(port (open-output-file tal-path)))
|
|
(display prog-text port)
|
|
(close-output-port port)
|
|
(system* asm-cmd)
|
|
rom-path))
|
|
|
|
(define (read-output port)
|
|
(let ((s (read-string #f port)))
|
|
(if (eq? s #!eof) "" s)))
|
|
|
|
(define emulator "./vm")
|
|
;(define emulator "uxncli")
|
|
|
|
(define (run-rom prog-text emu-args input-text)
|
|
(let*-values (((rom-path) (create-rom prog-text))
|
|
((args) (cons rom-path emu-args))
|
|
((c-out c-in c-pid c-err) (process* emulator args)))
|
|
(display input-text c-in)
|
|
(close-output-port c-in)
|
|
(let*-values (((out-text) (read-output c-out))
|
|
((err-text) (read-output c-err))
|
|
((pid ok status) (process-wait c-pid))
|
|
((exit-code) (if ok status (- status))))
|
|
(values exit-code out-text err-text))))
|
|
|
|
(define (it-failed test-name caption got expected)
|
|
(if (equal? got expected) #f
|
|
(begin
|
|
(display test-name)
|
|
(display ": ")
|
|
(display caption)
|
|
(display " failed; got '")
|
|
(display got)
|
|
(display "' but expected '")
|
|
(display expected)
|
|
(display "'\n")
|
|
#t)))
|
|
|
|
(define (test-rom test-name prog-text emu-args input-text expect-code expect-out expect-err)
|
|
(let-values (((exit-code out-text err-text) (run-rom prog-text emu-args input-text))
|
|
((ok) (values #t)))
|
|
(if (it-failed test-name "stdout" out-text expect-out) (set! ok #f) '())
|
|
(if (it-failed test-name "stderr" err-text expect-err) (set! ok #f) '())
|
|
(if (it-failed test-name "exit-code" exit-code expect-code) (set! ok #f) '())
|
|
ok))
|
|
|
|
(define (run-test test-name prog-text emu-args input-text expect-code expect-out expect-err)
|
|
(let ((ok (test-rom test-name prog-text emu-args input-text expect-code expect-out expect-err)))
|
|
(set! tests-ran (+ tests-ran 1))
|
|
(if ok
|
|
(set! tests-passed (+ tests-passed 1))
|
|
(set! tests-failed (+ tests-failed 1)))
|
|
(display (if ok " + " " E "))
|
|
(display test-name)
|
|
(display "\n")))
|
|
|
|
(define (display-system* cmd)
|
|
(display "$ ")
|
|
(display cmd)
|
|
(display "\n")
|
|
(system* cmd))
|
|
|
|
(display-system* "csc -o vm vm.scm")
|
|
|
|
(display "running tests...\n\n")
|
|
|
|
(run-test "zero exit" "|100 #800f DEO BRK" '() "" 0 "" "")
|
|
(run-test "non-zero exit" "|100 #110f DEO BRK" '() "" 17 "" "")
|
|
(run-test "echo A to stdout" "|100 #4118 DEO #800f DEO BRK" '() "" 0 "A" "")
|
|
(run-test "echo A to stderr" "|100 #4119 DEO #800f DEO BRK" '() "" 0 "" "A")
|
|
(run-test "test SWP" "|100 #40 #4142 SWP #18 DEO #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "AB@" "")
|
|
(run-test "test DUP" "|100 #40 #41 DUP #18 DEO #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "AA@" "")
|
|
(run-test "test DUPk" "|100 #4042 DUPk #18 DEO #18 DEO #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "BBB@" "")
|
|
(run-test "test DUP2" "|100 #40 #4318 DUP2 DEO DEO #18 DEO #800f DEO BRK" '() "" 0 "CC@" "")
|
|
(run-test "test DEOk" "|100 #4041 #18 DEOk DEO #18 DEO #800f DEO BRK" '() "" 0 "AA@" "")
|
|
(run-test "test DEOkr" "|100 #40 LIT2r 4218 DEOkr DEOr #18 DEO #800f DEO BRK" '() "" 0 "BB@" "")
|
|
(run-test "test ROT" "|100 #4041 #4342 ROT #18 DEO #18 DEO #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "ABC@" "")
|
|
(run-test "test SWP2" "|100 #40 #4241 #4443 SWP2 #18 DEO #18 DEO #18 DEO #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "ABCD@" "")
|
|
(run-test "test NIP" "|100 #40 #4241 NIP #18 DEO #18 DEO #800f DEO BRK" '() "" 0 "A@" "")
|
|
|
|
(display "\nsummary: ran ")
|
|
(display tests-ran)
|
|
(display " tests\n")
|
|
|
|
(display " ")
|
|
(display tests-passed)
|
|
(display " passed\n")
|
|
|
|
(display " ")
|
|
(display tests-failed)
|
|
(display " failed\n")
|