finish console implementation and add file device

exe/uxnemu.ml

@@ -64,14 +64,11 @@ let print_stack ~name (Machine.Stack { data; sp }) =
     (Fmt.on_bytes (Fmt.octets ()))
     (Bytes.sub data 0 sp)
 
-let rec run m pc =
+let console_vector = ref 0
+
+let run m pc =
   let dev = Machine.dev m in
-  let console_vector = ref 0 in
+  let ram = Machine.ram m in
-  let console_input ch ty =
-    Bytes.set_uint8 dev 0x12 ch;
-    Bytes.set_uint8 dev 0x17 ty;
-    if Bytes.get_uint8 dev 0x0f = 0 then run m !console_vector
-  in
   try Machine.dispatch ~trace:debug m pc with
   | effect Machine.Trace (pc, instr, args), k when debug ->
       Fmt.epr "PC = %04x | %6s %a@." pc (Instr.to_string instr)
@@ -80,14 +77,6 @@ let rec run m pc =
       Out_channel.flush stderr;
       continue k ()
   | effect Machine.Trace _, k -> continue k ()
-  | effect Machine.BRK, _ when !console_vector != 0 -> (
-      try
-        while Bytes.get_uint8 dev 0x0f = 0 do
-          match In_channel.input_byte stdin with
-          | None -> raise Exit
-          | Some c -> console_input c 1
-        done
-      with Exit -> console_input 0 4)
   | effect Machine.BRK, _ -> ()
   | effect Machine.DEI (`Byte, port), k ->
       let value =
@@ -119,15 +108,67 @@ let rec run m pc =
             Out_channel.flush stderr
           end
       | 0x0f -> Bytes.set_uint8 dev 0x0f value
-      | 0x10 -> console_vector := value
+      | 0x10 -> console_vector := Bytes.get_uint16_be dev 0x10
-      | 0x18 -> print_char (Char.chr value)
+      | 0x18 ->
-      | 0x19 -> prerr_char (Char.chr value)
+          print_char (Char.chr value);
+          Out_channel.flush stdout
+      | 0x19 ->
+          prerr_char (Char.chr value);
+          Out_channel.flush stderr
+      | 0xaa -> Varvara.File.file_lengths.(0) <- Bytes.get_uint16_be dev 0xaa
+      | 0xa4 ->
+          let addr = Bytes.get_uint16_be dev 0xa4 in
+          let len = Varvara.File.file_lengths.(0) in
+          let result = Varvara.File.file_stat ram 0 addr len in
+          Varvara.File.file_success dev 0xa2 result
+      | 0xa6 ->
+          let result = Varvara.File.file_delete 0 in
+          Varvara.File.file_success dev 0xa2 (if result = 0 then 1 else 0)
+      | 0xa8 ->
+          let addr = Bytes.get_uint16_be dev 0xa8 in
+          let result = Varvara.File.file_init ram 0 addr in
+          Varvara.File.file_success dev 0xa2 result
+      | 0xac ->
+          let addr = Bytes.get_uint16_be dev 0xac in
+          let len = Varvara.File.file_lengths.(0) in
+          let result = Varvara.File.file_read ram 0 addr len in
+          Varvara.File.file_success dev 0xa2 result
+      | 0xae ->
+          let addr = Bytes.get_uint16_be dev 0xae in
+          let len = Varvara.File.file_lengths.(0) in
+          let append = Bytes.get_uint8 dev 0xa7 in
+          let result = Varvara.File.file_write ram 0 addr len append in
+          Varvara.File.file_success dev 0xa2 result
+      | 0xba -> Varvara.File.file_lengths.(1) <- Bytes.get_uint16_be dev 0xba
+      | 0xb4 ->
+          let addr = Bytes.get_uint16_be dev 0xb4 in
+          let len = Varvara.File.file_lengths.(1) in
+          let result = Varvara.File.file_stat ram 1 addr len in
+          Varvara.File.file_success dev 0xb2 result
+      | 0xb6 ->
+          let result = Varvara.File.file_delete 1 in
+          Varvara.File.file_success dev 0xb2 (if result = 0 then 1 else 0)
+      | 0xb8 ->
+          let addr = Bytes.get_uint16_be dev 0xb8 in
+          let result = Varvara.File.file_init ram 1 addr in
+          Varvara.File.file_success dev 0xb2 result
+      | 0xbc ->
+          let addr = Bytes.get_uint16_be dev 0xbc in
+          let len = Varvara.File.file_lengths.(1) in
+          let result = Varvara.File.file_read ram 1 addr len in
+          Varvara.File.file_success dev 0xb2 result
+      | 0xbe ->
+          let addr = Bytes.get_uint16_be dev 0xbe in
+          let len = Varvara.File.file_lengths.(1) in
+          let append = Bytes.get_uint8 dev 0xb7 in
+          let result = Varvara.File.file_write ram 1 addr len append in
+          Varvara.File.file_success dev 0xb2 result
       | _ -> ());
       continue k ()
 
 let main () =
   if Array.length Sys.argv < 2 then (
-    Fmt.epr "usage: uxnemu file.rom ...\n";
+    Fmt.epr "usage: uxnemu file.rom\n";
     exit 1);
 
   let code =
@@ -138,12 +179,42 @@ let main () =
   Out_channel.set_binary_mode stdout true;
 
   let mach = Machine.create code in
-  Bytes.set (Machine.dev mach) 0 '\x00';
+  let dev = Machine.dev mach in
+
+  let has_args = Array.length Sys.argv > 2 in
+  Bytes.set_uint8 dev 0x17 (if has_args then 1 else 0);
+
   run mach 0x100;
+
+  if !console_vector <> 0 then begin
+    let console_input ch ty =
+      Bytes.set_uint8 dev 0x12 ch;
+      Bytes.set_uint8 dev 0x17 ty;
+      if Bytes.get_uint8 dev 0x0f = 0 then run mach !console_vector
+    in
+    if has_args then begin
+      for i = 2 to Array.length Sys.argv - 1 do
+        let arg = Sys.argv.(i) in
+        String.iter
+          (fun c ->
+            if Bytes.get_uint8 dev 0x0f = 0 then console_input (Char.code c) 2)
+          arg;
+        if Bytes.get_uint8 dev 0x0f = 0 then
+          console_input 0 (if i = Array.length Sys.argv - 1 then 4 else 3)
+      done
+    end;
+    try
+      while Bytes.get_uint8 dev 0x0f = 0 do
+        match In_channel.input_byte stdin with
+        | None -> raise Exit
+        | Some c -> console_input c 1
+      done
+    with Exit -> console_input 0 4
+  end;
   if debug then begin
     print_stack ~name:"wst" (Machine.wst mach);
     print_stack ~name:"rst" (Machine.rst mach)
   end;
-  exit (Bytes.get_uint8 (Machine.dev mach) 0x0f land 0x7f)
+  exit (Bytes.get_uint8 dev 0x0f land 0x7f)
 
 let _ = main ()

lib/Varvara/File.ml

@@ -0,0 +1,200 @@
+type file_state =
+  | Idle
+  | File_read of in_channel
+  | File_write of out_channel
+  | Dir_read of Unix.dir_handle * string (* dir_handle, filepath *)
+  | Dir_write
+
+type file_device = {
+  mutable filepath : string option;
+  mutable state : file_state;
+}
+
+let create_file_device () = { filepath = None; state = Idle }
+let file_devices = [| create_file_device (); create_file_device () |]
+let file_lengths = [| 0; 0 |]
+
+(* Read null-terminated string from RAM *)
+let read_cstring ram addr =
+  let buf = Buffer.create 256 in
+  let rec loop pos =
+    if pos >= Bytes.length ram then Buffer.contents buf
+    else
+      let c = Bytes.get ram pos in
+      if c = '\x00' then Buffer.contents buf
+      else (
+        Buffer.add_char buf c;
+        loop (pos + 1))
+  in
+  loop addr
+
+let file_reset dev =
+  (match dev.state with
+  | File_read ic -> close_in_noerr ic
+  | File_write oc -> close_out_noerr oc
+  | Dir_read (dh, _) -> Unix.closedir dh
+  | Idle | Dir_write -> ());
+  dev.state <- Idle
+
+let file_init ram id addr =
+  let dev = file_devices.(id) in
+  file_reset dev;
+  dev.filepath <- Some (read_cstring ram addr);
+  0
+
+let file_not_ready id =
+  match file_devices.(id).filepath with
+  | None ->
+      Format.eprintf "File %d is uninitialized@." id;
+      true
+  | Some _ -> false
+
+let format_size size len =
+  let hex_digits = "0123456789abcdef" in
+  let buf = Bytes.create len in
+  for i = 0 to len - 1 do
+    let shift = 4 * (len - 1 - i) in
+    let nibble = (size lsr shift) land 0xf in
+    Bytes.set buf i hex_digits.[nibble]
+  done;
+  Bytes.to_string buf
+
+let format_stat ?(capsize = false) filepath len =
+  try
+    let st = Unix.stat filepath in
+    let is_dir = st.Unix.st_kind = Unix.S_DIR in
+    if is_dir then String.make len '-'
+    else if capsize && st.Unix.st_size >= 0x10000 then String.make len '?'
+    else format_size st.Unix.st_size len
+  with Unix.Unix_error _ -> String.make len '!'
+
+let format_dir_entry filepath basename =
+  let full_path = Filename.concat filepath basename in
+  let stat_str = format_stat ~capsize:true full_path 4 in
+  try
+    let st = Unix.stat full_path in
+    let is_dir = st.Unix.st_kind = Unix.S_DIR in
+    Printf.sprintf "%s %s%s\n" stat_str basename (if is_dir then "/" else "")
+  with Unix.Unix_error _ -> Printf.sprintf "%s %s\n" stat_str basename
+
+let read_directory filepath maxlen =
+  let dh = Unix.opendir filepath in
+  let buf = Buffer.create 1024 in
+  let rec read_entries () =
+    try
+      let entry = Unix.readdir dh in
+      if entry <> "." && entry <> ".." then
+        Buffer.add_string buf (format_dir_entry filepath entry);
+      if Buffer.length buf < maxlen then read_entries ()
+    with End_of_file -> ()
+  in
+  read_entries ();
+  Unix.closedir dh;
+  let result = Buffer.contents buf in
+  if String.length result > maxlen then String.sub result 0 maxlen else result
+
+let create_directories path =
+  let rec mkdir_parents p =
+    if p <> "" && p <> "." && p <> "/" then
+      if not (Sys.file_exists p) then (
+        mkdir_parents (Filename.dirname p);
+        try Unix.mkdir p 0o755 with Unix.Unix_error _ -> ())
+  in
+  mkdir_parents (Filename.dirname path)
+
+let is_dir_path path =
+  String.length path > 0 && path.[String.length path - 1] = '/'
+
+let file_read ram id addr len =
+  if file_not_ready id then 0
+  else
+    let dev = file_devices.(id) in
+    match dev.filepath with
+    | None -> 0
+    | Some filepath -> (
+        (match dev.state with
+        | Idle ->
+            if Sys.is_directory filepath then
+              dev.state <- Dir_read (Unix.opendir filepath, filepath)
+            else dev.state <- File_read (open_in_bin filepath)
+        | _ -> ());
+        match dev.state with
+        | File_read ic -> (
+            try
+              let bytes_read = input ic ram addr len in
+              bytes_read
+            with
+            | End_of_file -> 0
+            | Sys_error _ -> 0)
+        | Dir_read (dh, fp) -> (
+            try
+              let contents = read_directory fp len in
+              let bytes_to_copy = min len (String.length contents) in
+              Bytes.blit_string contents 0 ram addr bytes_to_copy;
+              Unix.closedir dh;
+              dev.state <- Idle;
+              bytes_to_copy
+            with Unix.Unix_error _ -> 0)
+        | _ -> 0)
+
+let file_write ram id addr len append_flag =
+  if file_not_ready id then 0
+  else
+    let dev = file_devices.(id) in
+    match dev.filepath with
+    | None -> 0
+    | Some filepath -> (
+        (match dev.state with
+        | Idle ->
+            if is_dir_path filepath then (
+              create_directories filepath;
+              dev.state <- Dir_write)
+            else (
+              create_directories filepath;
+              let mode =
+                if append_flag land 0x01 <> 0 then
+                  [ Open_wronly; Open_binary; Open_append; Open_creat ]
+                else [ Open_wronly; Open_binary; Open_creat; Open_trunc ]
+              in
+              try
+                let oc = open_out_gen mode 0o644 filepath in
+                dev.state <- File_write oc
+              with Sys_error _ -> ())
+        | _ -> ());
+        match dev.state with
+        | File_write oc -> (
+            try
+              output oc ram addr len;
+              flush oc;
+              len
+            with Sys_error _ -> 0)
+        | Dir_write ->
+            if Sys.file_exists filepath && Sys.is_directory filepath then 1
+            else 0
+        | _ -> 0)
+
+let file_stat ram id addr len =
+  if file_not_ready id then 0
+  else
+    let dev = file_devices.(id) in
+    match dev.filepath with
+    | None -> 0
+    | Some filepath ->
+        let stat_str = format_stat filepath len in
+        let bytes_to_copy = min len (String.length stat_str) in
+        Bytes.blit_string stat_str 0 ram addr bytes_to_copy;
+        bytes_to_copy
+
+let file_delete id =
+  if file_not_ready id then -1
+  else
+    let dev = file_devices.(id) in
+    match dev.filepath with
+    | None -> -1
+    | Some filepath -> (
+        try
+          Unix.unlink filepath;
+          0
+        with Unix.Unix_error _ -> -1)
+
+let file_success dev port value = Bytes.set_uint16_be dev port value

shell.nix

@@ -1,4 +1,7 @@
-{ pkgs ? import <nixpkgs> {} }:
+{
+  pkgs ? import <nixpkgs> { },
+}:
+
 pkgs.mkShell {
   buildInputs = with pkgs; [
     xxd