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))
+(import (chicken bitwise))
-(define (get-u8 port)
+(import (chicken file))
-  (let ((c (read-char port))) (if (eof-object? c) c (char->integer c))))
+(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))
+    (vector-set! v 5 (+ y 1900)) v))
-    v))
 
 ;; ;; guile, invoke with guile vm.scm ROM ...
 ;; (use-modules (srfi srfi-60) (ice-9 binary-ports))
@@ -69,16 +72,14 @@
 (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)
 (define _wst wst)
 (define _rst rst)
 
-;; file devices
-;; [fh, path, state]
-(define _files (vector (make-vector 4) (make-vector 4)))
-
 ;; convert numbers to 8-bit and 16-bit values
 (define (u8 n) (modulo n 256))
 (define (s8 n) (- (u8 (+ n 128)) 128))
@@ -140,13 +141,6 @@
         (lo (vector-ref mem (u16 (+ pc 1)))))
     (s16 (hilo->u16 hi lo))))
 
-(define (_dev_read1 port)
-  (vector-ref dev port))
-(define (_dev_read2 port)
-  (let ((hi (vector-ref dev port))
-        (lo (vector-ref dev (u8 (+ port 1)))))
-    (hilo->u16 hi lo)))
-
 ;; restore a stack pointer when in keep mode
 (define (restore k)
   (if (null? k)
@@ -250,104 +244,16 @@
           (_deo (u16->hi n) dev)
           (_deo (u16->lo n) (u8 (+ dev 1))))
         (_deo n dev))))
-
 (define (_deo byte port)
   (vector-set! dev port (u8 byte))
-  (let ((d (b>> port 4))
-        (f (bitwise-and port 15)))
-    (cond
-     ((= d 0) (_system_deo byte f))
-     ((= d 1) (_console_deo byte f))
-     ((= d 10) (_file_deo 10 byte f))
-     ((= d 11) (_file_deo 11 byte f))
-     (* '()))))
-
-(define (_system_deo byte field)
   (cond
-   ((= 4 field) (set-car! wst byte))
+   ((= 4 port) (set-car! wst byte))
-   ((= 5 field) (set-car! rst byte))
+   ((= 5 port) (set-car! rst byte))
-   ((= 14 field) (u:debug))
+   ((= 14 port) (u:debug))
+   ((= 24 port) (write-byte byte (current-output-port)))
+   ((= 25 port) (write-byte byte (current-error-port)))
    (* '())))
 
-(define (_console_deo byte field)
-  (cond
-   ((= 8 field) (write-char (integer->char byte) (current-output-port)))
-   ((= 9 field) (write-char (integer->char byte) (current-error-port)))))
-
-;; 0 1     vector
-;; 2 3     success
-;; 4 [5]   stat
-;; [6]     delete
-;; 7       append
-;; 8 [9]   name
-;; 10 11   length
-;; 12 [13] read
-;; 14 [15] write
-(define (_file_deo d byte field)
-  (let* ((index (- d 10))
-         (file (vector-ref files index)))
-    (cond
-     ((= 5 field) '())                  ; stat
-     ((= 6 field) '())                  ; delete
-     ((= 9 field) (_file_init file))    ; name
-     ((= 13 field) '())                 ; read
-     ((= 15 field) '())                 ; write
-     (* '()))))                         ; default
-
-;; [fh, path, state]
-(define (_file-init file d)
-  (let* ((addr (_dev_read2 (+ d 8)))
-         (maxlen (_dev_read2 (+ d 10)))
-         (s (_load-string addr maxlen)))
-    (display "initializing ")
-    (display s)
-    (display "\n")
-    (_file-reset file)
-    (vector-set! file 0 '())
-    (vector-set! file 1 s)
-    (vector-set! file 2 'idle)))
-
-(define (_file-stat file addr len) (display "_file_stat TODO\n"))
-(define (_file-delete file) (display "_file_delte TODO\n"))
-(define (_file-read file addr len) (display "_file_read TODO\n"))
-
-(define (_f-state file) (vector-ref file 2))
-(define (_f-state-set! file state) (vector-set! file 2 state))
-(define (_f-path file) (vector-ref file 1))
-(define (_f-path-set! file path) (vector-set! file 1 path))
-(define (_f-is-dir? file) #f)
-
-(define (_file-write file addr len append?)
-    (if (not (or (eq? (_f-state file) 'file-write)
-                 (eq? (_f-state file) 'dir-write)))
-        (_file-reset file)
-        (if (_f-is-dir? file)
-            (_f-state-set! file 'dir-write)
-            ; TODO: open file handle, wb or ab
-            (_f-state-set! file 'file-write)))
-    (if (eq? (_f-state file) 'file-write)
-        (display "_file_write file TODO\n")
-        (display "_file_write dir TODO\n")))
-
-(define (_path-is-dir path) #f)
-
-(define (_file-reset file)
-  '())
-
-(define (_ensure-parent-dirs path)
-  '())
-
-(define (_load-string addr maxlen)
-  (let* ((out (open-output-string)))
-    (define (loop i)
-      (let ((c (if (< i maxlen) (vector-ref addr i) 0)))
-        (if (= c 0) (get-output-string out)
-            (begin
-              (write-char (integer->char c) out)
-              (loop (+ i 1))))))
-    (loop 0)))
-
-
 (define (u:debug)
   (u:debug-stack "WST" wst) (u:debug-stack "RST" rst))
 
@@ -444,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
@@ -472,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)))
+  (let ((byte (read-byte port)))
-    (if (eof-object? c)
+    (if (eof-object? byte)
-        (u:send-input #\newline 4)
+        (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
@@ -498,16 +406,44 @@
         (begin (vector-set! mem addr (u8 byte))
                (u:load-rom rom (+ addr 1))))))
 
-(let ((prog-args (command-line-arguments)))
+(define (u:read-cmd cmd)
-  (if (null? prog-args)
+  (with-input-from-pipe cmd (lambda () (read-string #f (current-input-port)))))
-      (begin (display "usage: ./vm ROM [ARGS...]\n") (exit))
+
-      (let* ((rom-path (car prog-args))
+(define (u:usage)
-             (rom-args (cdr prog-args))
+  (display "usage: ./vm [-raw] ROM [ARGS...]\n")
-             (rom (open-rom rom-path))
+  (exit))
-             (start 256))
+
-        (vector-set! dev 23 (if (null? rom-args) 0 1))
+(define (u:parse-args args)
-        (u:load-rom rom start)
+  (if (null? args) (u:usage))
-        (u:run start)
+  (if (equal? (car args) "-raw")
-        (if (null? rom-args) '() (u:read-args rom-args))
+      (begin (set! raw-tty #t)
-        (u:read-stdin (current-input-port))
+             (u:parse-args (cdr args)))
-        (exit 0))))
+      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))