In-progress file device support.

vm.scm

@@ -75,6 +75,10 @@
 (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))
@@ -136,6 +140,13 @@
         (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)
@@ -239,16 +250,104 @@
           (_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
-   ((= 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)))
+     ((= 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))
+   ((= 5 field) (set-car! rst byte))
+   ((= 14 field) (u:debug))
    (* '())))
 
+(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))