add -raw mode for vm.scm

test.scm

@@ -0,0 +1,104 @@
+(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")

vm.scm

@@ -7,15 +7,18 @@
 ;; === implementation-dependent functions; uncomment one stanza
 
 ;; chicken scheme
-(import (chicken bitwise) (chicken process-context) (chicken time posix))
-(define (get-u8 port)
-  (let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
+(import (chicken bitwise))
+(import (chicken file))
+(import (chicken process))
+(import (chicken process-context))
+(import (chicken time posix))
+(import (chicken io))
+(define (get-u8 port) (read-byte port))
 (define (open-rom path) (open-input-file path #:binary))
 (define (get-date-time)
   (let* ((v (seconds->local-time))
          (y (vector-ref v 5)))
-    (vector-set! v 5 (+ y 1900))
-    v))
+    (vector-set! v 5 (+ y 1900)) v))
 
 ;; ;; guile, invoke with guile vm.scm ROM ...
 ;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
@@ -69,6 +72,8 @@
 (define rst (cons 0 (make-vector 256 0)))
 (define pc 256)
 (define done #f)
+(define raw-tty #f)
+(define saved-tty '())
 
 ;; instruction modes
 (define _2 #f)
@@ -245,8 +250,8 @@
    ((= 4 port) (set-car! wst byte))
    ((= 5 port) (set-car! rst byte))
    ((= 14 port) (u:debug))
-   ((= 24 port) (write-char (integer->char byte) (current-output-port)))
-   ((= 25 port) (write-char (integer->char byte) (current-error-port)))
+   ((= 24 port) (write-byte byte (current-output-port)))
+   ((= 25 port) (write-byte byte (current-error-port)))
    (* '())))
 
 (define (u:debug)
@@ -345,26 +350,28 @@
         (fn)
         (u:eval))))
 
+(define (u:exit n) (u:restore-tty) (exit n))
+
 (define (u:run addr)
   (set! done #f)
   (set! pc addr)
   (u:eval)
   (let ((n (vector-ref dev 15)))
     (if (= n 0) '()
-        (exit (bitwise-and n 127)))))
+        (u:exit (bitwise-and n 127)))))
 
 (define (u:read-args args)
   (if (null? args)
-      (u:send-input #\newline 4)
+      (u:send-input 10 4)
       (begin
         (u:read-arg (string->list (car args)))
-        (if (null? (cdr args)) '() (u:send-input #\newline 3))
+        (if (null? (cdr args)) '() (u:send-input 10 3))
         (u:read-args (cdr args)))))
 
 (define (u:read-arg chars)
   (if (null? chars) '()
       (begin
-        (u:send-input (car chars) 2)
+        (u:send-input (char->integer (car chars)) 2)
         (u:read-arg (cdr chars)))))
 
 ;; send a character of console input with type
@@ -373,22 +380,22 @@
 ;; - 2 argument data
 ;; - 3 spacer between arguments
 ;; - 4 spacer after arguments, or end of stdin
-(define (u:send-input c type)
+(define (u:send-input n type)
   (let* ((hi (vector-ref dev 16))
          (lo (vector-ref dev 17))
          (addr (hilo->u16 hi lo)))
     (if (= 0 addr) '()
         (begin
-          (vector-set! dev 18 (u8 (char->integer c)))
+          (vector-set! dev 18 (u8 n))
           (vector-set! dev 23 (u8 type))
           (u:run addr)))))
 
 (define (u:read-stdin port)
-  (let ((c (read-char port)))
-    (if (eof-object? c)
-        (u:send-input #\newline 4)
+  (let ((byte (read-byte port)))
+    (if (eof-object? byte)
+        (u:send-input 10 4)
         (begin
-          (u:send-input c 1)
+          (u:send-input byte 1)
           (u:read-stdin port)))))
 
 ;; load a ROM from a file, byte-by-byte
@@ -399,16 +406,44 @@
         (begin (vector-set! mem addr (u8 byte))
                (u:load-rom rom (+ addr 1))))))
 
-(let ((prog-args (command-line-arguments)))
-  (if (null? prog-args)
-      (begin (display "usage: ./vm ROM [ARGS...]\n") (exit))
-      (let* ((rom-path (car prog-args))
-             (rom-args (cdr prog-args))
-             (rom (open-rom rom-path))
-             (start 256))
-        (vector-set! dev 23 (if (null? rom-args) 0 1))
-        (u:load-rom rom start)
-        (u:run start)
-        (if (null? rom-args) '() (u:read-args rom-args))
-        (u:read-stdin (current-input-port))
-        (exit 0))))
+(define (u:read-cmd cmd)
+  (with-input-from-pipe cmd (lambda () (read-string #f (current-input-port)))))
+
+(define (u:usage)
+  (display "usage: ./vm [-raw] ROM [ARGS...]\n")
+  (exit))
+
+(define (u:parse-args args)
+  (if (null? args) (u:usage))
+  (if (equal? (car args) "-raw")
+      (begin (set! raw-tty #t)
+             (u:parse-args (cdr args)))
+      args))
+
+(define (u:check-rom path)
+  (if (and (file-exists? path) (file-readable? path)) '()
+      (begin (display "ERROR: cannot open ROM '")
+             (display path)
+             (display "'\n")
+             (u:usage))))
+
+(define (u:set-tty)
+  (if raw-tty (begin (set! saved-tty (u:read-cmd "stty -g"))
+                     (system* "stty raw -echo"))))
+
+(define (u:restore-tty)
+  (if raw-tty (system* (string-append "stty " saved-tty))))
+
+(let* ((prog-args (u:parse-args (command-line-arguments)))
+       (_ (u:set-tty))
+       (rom-path (car prog-args))
+       (rom-args (cdr prog-args))
+       (_ (u:check-rom rom-path))
+       (rom (open-rom rom-path))
+       (start 256))
+  (vector-set! dev 23 (if (null? rom-args) 0 1))
+  (u:load-rom rom start)
+  (u:run start)
+  (if (null? rom-args) '() (u:read-args rom-args))
+  (u:read-stdin (current-input-port))
+  (u:exit 0))