From 7f99b487dff9adcaf1073f743951178fc49584b5 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Sun, 14 Dec 2025 22:21:10 -0300 Subject: [PATCH 01/10] finish console implementation and add file device --- exe/uxnemu.ml | 113 ++++++++++++++++++++----- lib/Varvara/File.ml | 200 ++++++++++++++++++++++++++++++++++++++++++++ shell.nix | 5 +- 3 files changed, 296 insertions(+), 22 deletions(-) create mode 100644 lib/Varvara/File.ml diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 3e14f16..40453ea 100644 --- a/exe/uxnemu.ml +++ b/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 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 + let ram = Machine.ram m 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 - | 0x18 -> print_char (Char.chr value) - | 0x19 -> prerr_char (Char.chr value) + | 0x10 -> console_vector := Bytes.get_uint16_be dev 0x10 + | 0x18 -> + 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 () diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml new file mode 100644 index 0000000..b94c154 --- /dev/null +++ b/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 diff --git a/shell.nix b/shell.nix index 786f1c7..995cec9 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,7 @@ -{ pkgs ? import {} }: +{ + pkgs ? import { }, +}: + pkgs.mkShell { buildInputs = with pkgs; [ xxd From 7b8871ffd9091b07e417aa358eede8fd65c034df Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Sun, 14 Dec 2025 22:33:49 -0300 Subject: [PATCH 02/10] update README and .gitignore --- .gitignore | 1 + README.md | 5 ----- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/.gitignore b/.gitignore index b1d2cf0..a116061 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ /_opam /_build /utils/uxnmin +/.envrc diff --git a/README.md b/README.md index 156bc39..c486be7 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,2 @@ Yet another Uxn core, this time as an OCaml library. - It has no dependencies, and depends on OCaml >=5.3 for its effect syntax. - -It was made for use in Llop, a concatenative language targetting the Uxn virtual -machine, but can be used for other purposes. See `exe/uxnemu.ml` for a minimal -Uxn/Varvara emulator that is able to run programs like Drifloon. From 5769f6d470e187d455418722958769ac1a3c43b7 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 13:03:39 -0300 Subject: [PATCH 03/10] begin work on new device module system --- exe/dune | 2 +- exe/uxnemu.ml | 128 ++++++++--------------------------------- lib/Device.ml | 34 +++++++++++ lib/Machine.ml | 4 +- lib/Machine.mli | 2 +- lib/Varvara/Console.ml | 21 +++++++ lib/Varvara/File.ml | 5 +- lib/Varvara/System.ml | 100 ++++++++++++++++++++++++++++++++ lib/Varvara/dune | 3 + lib/dune | 2 - shell.nix | 1 + 11 files changed, 190 insertions(+), 112 deletions(-) create mode 100644 lib/Device.ml create mode 100644 lib/Varvara/Console.ml create mode 100644 lib/Varvara/System.ml create mode 100644 lib/Varvara/dune diff --git a/exe/dune b/exe/dune index a95ce30..2cfc9e6 100644 --- a/exe/dune +++ b/exe/dune @@ -1,4 +1,4 @@ (executable (public_name uxnemu) (name uxnemu) - (libraries uxn unix fmt)) + (libraries uxn varvara unix fmt)) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 40453ea..b44d023 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -1,120 +1,41 @@ open Uxn open Effect.Deep -let debug = Option.is_some (Sys.getenv_opt "DBG") -let banks = Array.init 15 (fun _ -> Bytes.create 65536) +let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG") -let get_bank_memory mach bank = - if bank = 0 then Machine.ram mach - else if bank > 0 && bank < 16 then banks.(bank - 1) - else Bytes.create 0 - -let system_expansion mach cmd_addr = - let ram = Machine.ram mach in - let cmd = Bytes.get_uint8 ram cmd_addr in - match cmd with - | 0x00 -> - let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in - let bank = Bytes.get_uint16_be ram (cmd_addr + 3) in - let addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in - let value = Bytes.get_uint8 ram (cmd_addr + 7) in - if bank < 16 then begin - let mem = get_bank_memory mach bank in - for i = 0 to length - 1 do - let pos = (addr + i) land 0xffff in - Bytes.set_uint8 mem pos value - done - end - | 0x01 -> - let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in - let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in - let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in - let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in - let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in - if src_bank < 16 && dst_bank < 16 then begin - let src_mem = get_bank_memory mach src_bank in - let dst_mem = get_bank_memory mach dst_bank in - for i = 0 to length - 1 do - let src_pos = (src_addr + i) land 0xffff in - let dst_pos = (dst_addr + i) land 0xffff in - let v = Bytes.get_uint8 src_mem src_pos in - Bytes.set_uint8 dst_mem dst_pos v - done - end - | 0x02 -> - let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in - let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in - let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in - let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in - let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in - if src_bank < 16 && dst_bank < 16 then begin - let src_mem = get_bank_memory mach src_bank in - let dst_mem = get_bank_memory mach dst_bank in - for i = length - 1 downto 0 do - let src_pos = (src_addr + i) land 0xffff in - let dst_pos = (dst_addr + i) land 0xffff in - let v = Bytes.get_uint8 src_mem src_pos in - Bytes.set_uint8 dst_mem dst_pos v - done - end - | _ -> Fmt.epr "System/expansion: unknown command #%02x" cmd +module System = Varvara.System.Make () +module Console = Varvara.Console.Make () +module Devices = Uxn.Device.Compose (System) (Console) let print_stack ~name (Machine.Stack { data; sp }) = Fmt.epr "%s: @[%a@]@." name (Fmt.on_bytes (Fmt.octets ())) (Bytes.sub data 0 sp) -let console_vector = ref 0 - let run m pc = let dev = Machine.dev m in let ram = Machine.ram m 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) - (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x")) - args; - Out_channel.flush stderr; + try Machine.dispatch ~trace m pc with + | effect Machine.Trace (pc, instr, args), k -> + if trace then begin + Fmt.epr "PC = %04x | %6s %a@." pc (Instr.to_string instr) + (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x")) + args; + Out_channel.flush stderr + end; continue k () - | effect Machine.Trace _, k -> continue k () | effect Machine.BRK, _ -> () - | effect Machine.DEI (`Byte, port), k -> - let value = - match port with - | 0x04 -> - let (Machine.Stack { sp; _ }) = Machine.wst m in - sp - | 0x05 -> - let (Machine.Stack { sp; _ }) = Machine.rst m in - sp - | _ -> Bytes.get_uint8 dev port - in - continue k value - | effect Machine.DEI (`Short, port), k -> - continue k (Util.get_uint16_wrap ~wrap:0xffff dev port) + | effect Machine.DEI (`Byte, port), k -> ( + match Devices.dei m port with + | Some v -> continue k v + | None -> continue k (Bytes.get_uint8 dev port)) + | effect Machine.DEI (`Short, port), k -> ( + match Devices.dei2 m port with + | Some v -> continue k v + | None -> continue k (Util.get_uint16_wrap dev port)) | effect Machine.DEO (port, value), k -> (match port with - | 0x02 -> system_expansion m value - | 0x04 -> - let (Machine.Stack s) = Machine.wst m in - s.sp <- value land 0xff - | 0x05 -> - let (Machine.Stack s) = Machine.rst m in - s.sp <- value land 0xff - | 0x0e -> - if value <> 0 then begin - print_stack ~name:"WST" (Machine.wst m); - print_stack ~name:"RST" (Machine.rst m); - Out_channel.flush stderr - end - | 0x0f -> Bytes.set_uint8 dev 0x0f value - | 0x10 -> console_vector := Bytes.get_uint16_be dev 0x10 - | 0x18 -> - print_char (Char.chr value); - Out_channel.flush stdout - | 0x19 -> - prerr_char (Char.chr value); - Out_channel.flush stderr + | _ when Devices.can_handle port -> Devices.deo m port value | 0xaa -> Varvara.File.file_lengths.(0) <- Bytes.get_uint16_be dev 0xaa | 0xa4 -> let addr = Bytes.get_uint16_be dev 0xa4 in @@ -186,11 +107,11 @@ let main () = run mach 0x100; - if !console_vector <> 0 then begin + if Console.state.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 + if Bytes.get_uint8 dev 0x0f = 0 then run mach Console.state.console_vector in if has_args then begin for i = 2 to Array.length Sys.argv - 1 do @@ -211,7 +132,8 @@ let main () = done with Exit -> console_input 0 4 end; - if debug then begin + + if trace then begin print_stack ~name:"wst" (Machine.wst mach); print_stack ~name:"rst" (Machine.rst mach) end; diff --git a/lib/Device.ml b/lib/Device.ml new file mode 100644 index 0000000..bc87443 --- /dev/null +++ b/lib/Device.ml @@ -0,0 +1,34 @@ +module type DEVICE = sig + type state + + val state : state + val can_handle : int -> bool + val dei : Machine.machine -> int -> int option + val dei2 : Machine.machine -> int -> int option + val deo : Machine.machine -> int -> int -> unit +end + +module Compose (D1 : DEVICE) (D2 : DEVICE) : DEVICE = struct + type state = D1.state * D2.state + + let state = (D1.state, D2.state) + let can_handle port = D1.can_handle port || D2.can_handle port + + let dei mach port = + match (D1.can_handle port, D2.can_handle port) with + | true, false -> D1.dei mach port + | false, true -> D2.dei mach port + | _ -> None + + let dei2 mach port = + match (D1.can_handle port, D2.can_handle port) with + | true, false -> D1.dei2 mach port + | false, true -> D2.dei2 mach port + | _ -> None + + let deo mach port value = + match (D1.can_handle port, D2.can_handle port) with + | true, false -> D1.deo mach port value + | false, true -> D2.deo mach port value + | _ -> () +end diff --git a/lib/Machine.ml b/lib/Machine.ml index 1ca17cf..783b94b 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -92,7 +92,7 @@ let create code = Bytes.blit_string code 0 data 0x100 (String.length code); Machine { data; dev; stack = stack_create (); callstack = stack_create () } -let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) = +let dispatch ?(trace = false) (Machine m) (pc : int) = let pc = ref pc in while true do @@ -100,9 +100,7 @@ let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) = let op = Bytes.get_uint8 m.data !pc in let instr = Instr.of_int op in - let trace l = if trace then perform (Trace (!pc, instr, l)) in - if List.mem !pc breakpoints then perform (Breakpoint !pc); pc := (!pc + 1) land 0xffff; diff --git a/lib/Machine.mli b/lib/Machine.mli index 1d00709..f34d44b 100644 --- a/lib/Machine.mli +++ b/lib/Machine.mli @@ -27,4 +27,4 @@ type _ Effect.t += | Breakpoint : int -> unit Effect.t val create : string -> machine -val dispatch : ?trace:bool -> ?breakpoints:int list -> machine -> int -> 'a +val dispatch : ?trace:bool -> machine -> int -> 'a diff --git a/lib/Varvara/Console.ml b/lib/Varvara/Console.ml new file mode 100644 index 0000000..28bf22e --- /dev/null +++ b/lib/Varvara/Console.ml @@ -0,0 +1,21 @@ +type state = { mutable console_vector : int } + +module Make () : Uxn.Device.DEVICE with type state = state = struct + type nonrec state = state + + let state = { console_vector = 0 } + let can_handle port = port >= 0x10 && port <= 0x1f + let dei _ _ = None + let dei2 _ _ = None + + let deo _ port value = + match port with + | 0x10 -> state.console_vector <- value + | 0x18 -> + print_char (Char.chr value); + Out_channel.flush stdout + | 0x19 -> + prerr_char (Char.chr value); + Out_channel.flush stderr + | _ -> () +end diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml index b94c154..5670a91 100644 --- a/lib/Varvara/File.ml +++ b/lib/Varvara/File.ml @@ -8,10 +8,11 @@ type file_state = type file_device = { mutable filepath : string option; mutable state : file_state; + mutable length : int; } -let create_file_device () = { filepath = None; state = Idle } -let file_devices = [| create_file_device (); create_file_device () |] +let make_file () = { filepath = None; state = Idle; length = 0 } +let file_devices = [| make_file (); make_file () |] let file_lengths = [| 0; 0 |] (* Read null-terminated string from RAM *) diff --git a/lib/Varvara/System.ml b/lib/Varvara/System.ml new file mode 100644 index 0000000..58ab18f --- /dev/null +++ b/lib/Varvara/System.ml @@ -0,0 +1,100 @@ +open Uxn + +type state = { banks : bytes array } + +module Make () : Uxn.Device.DEVICE with type state = state = struct + type nonrec state = state + + let state = { banks = Array.init 15 (fun _ -> Bytes.create 65536) } + let can_handle port = port >= 0x00 && port <= 0x0f + + let print_stack ~name (Machine.Stack { data; sp }) = + Fmt.epr "%s: @[%a@]@." name + (Fmt.on_bytes (Fmt.octets ())) + (Bytes.sub data 0 sp) + + let get_bank mach bank = + if bank = 0 then Machine.ram mach + else if bank > 0 && bank < 16 then state.banks.(bank - 1) + else Bytes.create 0 + + let expansion mach cmd_addr = + let ram = Machine.ram mach in + let cmd = Bytes.get_uint8 ram cmd_addr in + match cmd with + | 0x00 -> + let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in + let bank = Bytes.get_uint16_be ram (cmd_addr + 3) in + let addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in + let value = Bytes.get_uint8 ram (cmd_addr + 7) in + if bank < 16 then begin + let mem = get_bank mach bank in + for i = 0 to length - 1 do + let pos = (addr + i) land 0xffff in + Bytes.set_uint8 mem pos value + done + end + | 0x01 -> + let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in + let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in + let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in + let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in + let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in + if src_bank < 16 && dst_bank < 16 then begin + let src_mem = get_bank mach src_bank in + let dst_mem = get_bank mach dst_bank in + for i = 0 to length - 1 do + let src_pos = (src_addr + i) land 0xffff in + let dst_pos = (dst_addr + i) land 0xffff in + let v = Bytes.get_uint8 src_mem src_pos in + Bytes.set_uint8 dst_mem dst_pos v + done + end + | 0x02 -> + let length = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 1) in + let src_bank = Bytes.get_uint16_be ram (cmd_addr + 3) in + let src_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 5) in + let dst_bank = Bytes.get_uint16_be ram (cmd_addr + 7) in + let dst_addr = Util.get_uint16_wrap ~wrap:0xffff ram (cmd_addr + 9) in + if src_bank < 16 && dst_bank < 16 then begin + let src_mem = get_bank mach src_bank in + let dst_mem = get_bank mach dst_bank in + for i = length - 1 downto 0 do + let src_pos = (src_addr + i) land 0xffff in + let dst_pos = (dst_addr + i) land 0xffff in + let v = Bytes.get_uint8 src_mem src_pos in + Bytes.set_uint8 dst_mem dst_pos v + done + end + | _ -> Format.eprintf "System/expansion: unknown command #%02x" cmd + + let dei m port = + match port with + | 0x04 -> + let (Machine.Stack { sp; _ }) = Machine.wst m in + Some sp + | 0x05 -> + let (Machine.Stack { sp; _ }) = Machine.rst m in + Some sp + | _ -> None + + let dei2 _ _ = None + + let deo mach port value = + match port with + | 0x02 -> expansion mach value + | 0x04 -> + let (Machine.Stack s) = Machine.wst mach in + s.sp <- value land 0xff + | 0x05 -> + let (Machine.Stack s) = Machine.rst mach in + s.sp <- value land 0xff + | 0x0e -> + if value <> 0 then begin + print_stack ~name:"wst" (Machine.wst mach); + print_stack ~name:"rst" (Machine.rst mach); + Out_channel.flush stderr + end + | 0x0f -> Bytes.set_uint8 (Machine.dev mach) 0x0f value + | _ -> () +end diff --git a/lib/Varvara/dune b/lib/Varvara/dune new file mode 100644 index 0000000..f7de2ae --- /dev/null +++ b/lib/Varvara/dune @@ -0,0 +1,3 @@ +(library + (name varvara) + (libraries uxn fmt unix)) diff --git a/lib/dune b/lib/dune index ba1ed70..03870e8 100644 --- a/lib/dune +++ b/lib/dune @@ -1,5 +1,3 @@ -(include_subdirs qualified) - (library (name uxn) (libraries unix)) diff --git a/shell.nix b/shell.nix index 995cec9..e6ad57a 100644 --- a/shell.nix +++ b/shell.nix @@ -5,6 +5,7 @@ pkgs.mkShell { buildInputs = with pkgs; [ xxd + uxn ocamlPackages.ocaml ocamlPackages.dune_3 ocamlPackages.findlib From b71cf4343ea5a6036fec0b22fc076a752ec4c93e Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 14:24:20 -0300 Subject: [PATCH 04/10] move File device to new module system --- exe/uxnemu.ml | 68 ++------ lib/Varvara/File.ml | 361 ++++++++++++++++++++++------------------- utils/Makefile | 2 +- utils/varvara.file.tal | 86 ++++++++++ 4 files changed, 291 insertions(+), 226 deletions(-) create mode 100644 utils/varvara.file.tal diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index b44d023..dec0ab1 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -5,7 +5,18 @@ let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG") module System = Varvara.System.Make () module Console = Varvara.Console.Make () -module Devices = Uxn.Device.Compose (System) (Console) + +module File = + Uxn.Device.Compose + (Varvara.File.Make (struct + let start_addr = 0xa0 + end)) + (Varvara.File.Make (struct + let start_addr = 0xb0 + end)) + +module Devices = + Uxn.Device.Compose (Uxn.Device.Compose (System) (Console)) (File) let print_stack ~name (Machine.Stack { data; sp }) = Fmt.epr "%s: @[%a@]@." name @@ -14,7 +25,6 @@ let print_stack ~name (Machine.Stack { data; sp }) = let run m pc = let dev = Machine.dev m in - let ram = Machine.ram m in try Machine.dispatch ~trace m pc with | effect Machine.Trace (pc, instr, args), k -> if trace then begin @@ -34,62 +44,12 @@ let run m pc = | Some v -> continue k v | None -> continue k (Util.get_uint16_wrap dev port)) | effect Machine.DEO (port, value), k -> - (match port with - | _ when Devices.can_handle port -> Devices.deo m port value - | 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 - | _ -> ()); + if Devices.can_handle port then Devices.deo m port value; 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 = diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml index 5670a91..d14ffc7 100644 --- a/lib/Varvara/File.ml +++ b/lib/Varvara/File.ml @@ -11,191 +11,210 @@ type file_device = { mutable length : int; } -let make_file () = { filepath = None; state = Idle; length = 0 } -let file_devices = [| make_file (); make_file () |] -let file_lengths = [| 0; 0 |] +module type ADDR = sig + val start_addr : int +end -(* 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 +module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = file_device = +struct + type state = file_device -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 state = { filepath = None; state = Idle; length = 0 } -let file_init ram id addr = - let dev = file_devices.(id) in - file_reset dev; - dev.filepath <- Some (read_cstring ram addr); - 0 + let can_handle port = + port >= Addr.start_addr && port <= Addr.start_addr + 0x0f -let file_not_ready id = - match file_devices.(id).filepath with - | None -> - Format.eprintf "File %d is uninitialized@." id; - true - | Some _ -> false + 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 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 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 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 file_init ram addr = + file_reset state; + state.filepath <- Some (read_cstring ram addr); + 0 -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 file_not_ready () = state.filepath |> Option.is_none -let read_directory filepath maxlen = - let dh = Unix.opendir filepath in - let buf = Buffer.create 1024 in - let rec read_entries () = + 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 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 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 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 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 is_dir_path path = - String.length path > 0 && path.[String.length path - 1] = '/' + 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 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 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 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 + let is_dir_path path = + String.length path > 0 && path.[String.length path - 1] = '/' + + let file_read ram addr len = + if file_not_ready () then 0 + else + match state.filepath with + | None -> 0 + | Some filepath -> ( + (match state.state with + | Idle -> + if Sys.is_directory filepath then + state.state <- Dir_read (Unix.opendir filepath, filepath) + else state.state <- File_read (open_in_bin filepath) + | _ -> ()); + match state.state with + | File_read ic -> ( 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 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; + state.state <- Idle; + bytes_to_copy + with Unix.Unix_error _ -> 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_write ram addr len append_flag = + if file_not_ready () then 0 + else + match state.filepath with + | None -> 0 + | Some filepath -> ( + (match state.state with + | Idle -> + if is_dir_path filepath then ( + create_directories filepath; + state.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 + state.state <- File_write oc + with Sys_error _ -> ()) + | _ -> ()); + match state.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_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_stat ram addr len = + if file_not_ready () then 0 + else + match state.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_success dev port value = Bytes.set_uint16_be dev port value + let file_delete () = + if file_not_ready () then -1 + else + match state.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 + let dei _ _ = None + let dei2 _ _ = None + + let deo mach port value = + let open Uxn in + let ram = Machine.ram mach in + let dev = Machine.dev mach in + let with_success result = + file_success dev (Addr.start_addr + 0x02) result + in + match port - Addr.start_addr with + | 0x0a -> state.length <- value + | 0x04 -> file_stat (Machine.ram mach) value state.length |> with_success + | 0x06 -> file_delete () |> with_success + | 0x08 -> file_init (Machine.ram mach) value |> with_success + | 0x0c -> file_read (Machine.ram mach) value state.length |> with_success + | 0x0e -> + let append = Bytes.get_uint8 dev (Addr.start_addr + 0x07) in + file_write ram value state.length append |> with_success + | _ -> () +end diff --git a/utils/Makefile b/utils/Makefile index fbe5a68..7d48a98 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -1,7 +1,7 @@ .PHONY: all clean .SUFFIXES: .tal .rom -all: uxnmin drifloon.rom opctest.rom +all: uxnmin drifloon.rom opctest.rom varvara.file.rom clean: rm -f uxnmin drifloon.rom opctest.rom diff --git a/utils/varvara.file.tal b/utils/varvara.file.tal new file mode 100644 index 0000000..1035789 --- /dev/null +++ b/utils/varvara.file.tal @@ -0,0 +1,86 @@ +( uxncli file.rom ) + +|10 @Console/vector $2 &read $1 &pad $4 &type $1 &write $1 &error $1 +|a0 @File/vector $2 &success $2 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2 + +|100 + +@on-reset ( -> ) + file/ + file/ + #0004 .File/success DEI2 NEQ2 ?fail + ;file/a1 LDA2 ;file/a2 LDA2 NEQ2 ?fail + ;dict/load str/ + ;file/b1 LDA2 ;file/b2 LDA2 NEQ2 ?fail + ;dict/append str/ + ;file/stat-buf file/ + ;file/stat-hs LDA2 LIT2 "00 NEQ2 ?fail + ;file/stat-ls LDA2 LIT2 "04 NEQ2 ?fail + ;dict/stat str/ + file/ + ;file/null-buf file/ + ;file/null-buf LDA2 LIT2 "!! NEQ2 ?fail + ;dict/delete str/ + #800f DEO + BRK + +@fail ( -> ) + ;dict/failed str/ + #010f DEO + BRK + +( +@|File ) + +@file/ ( -- ) + ;&name .File/name DEO2 + #0002 .File/length DEO2 + ;&a1 .File/write DEO2 + ( | append ) + ;&name .File/name DEO2 + #0002 .File/length DEO2 + #01 .File/append DEO + ;&b1 .File/write DEO2 + JMP2r + +@file/ ( -- ) + ;&name .File/name DEO2 + ( two more bytes than max length ) #0006 .File/length DEO2 + ;&load-buf .File/read DEO2 + JMP2r + +@file/ ( buf* -- ) + ;&name .File/name DEO2 + #0004 .File/length DEO2 + .File/stat DEO2 + JMP2r + +@file/ ( -- ) + ;&name .File/name DEO2 + #01 .File/delete DEO + JMP2r + + &name "test.txt $1 + +( +@|Utils ) + +@str/ ( str* -- ) + LDAk DUP ?{ POP POP2 JMP2r } + #18 DEO + INC2 !/ + +( +@|Data ) + +@dict/failed "File: 20 "fail 0a $1 + &load "File/load: 20 "pass 0a $1 + &append "File/append: 20 "pass 0a $1 + &stat "File/stat: 20 "pass 0a $1 + &delete "File/delete: 20 "pass 0a $1 + +@file/data &a1 1234 &b1 5678 + ( load buf ) &load-buf &a2 $2 &b2 $2 + ( stat buf ) &stat-buf &stat-hs $2 &stat-ls $2 + ( null buf ) &null-buf $4 + From bc1bae5977716e496a1f2b96ad811b792801e129 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 15:50:34 -0300 Subject: [PATCH 05/10] make #010e DEO print stack in the recommended repr --- exe/dune | 2 +- exe/uxnemu.ml | 21 +- lib/Machine.ml | 15 +- lib/Machine.mli | 7 - lib/Varvara/File.ml | 21 +- lib/Varvara/System.ml | 10 +- lib/Varvara/dune | 2 +- utils/drifblim.tal | 811 ++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 837 insertions(+), 52 deletions(-) create mode 100644 utils/drifblim.tal diff --git a/exe/dune b/exe/dune index 2cfc9e6..9d5c776 100644 --- a/exe/dune +++ b/exe/dune @@ -1,4 +1,4 @@ (executable (public_name uxnemu) (name uxnemu) - (libraries uxn varvara unix fmt)) + (libraries uxn varvara unix)) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index dec0ab1..7b2189a 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -9,28 +9,22 @@ module Console = Varvara.Console.Make () module File = Uxn.Device.Compose (Varvara.File.Make (struct - let start_addr = 0xa0 + let start = 0xa0 end)) (Varvara.File.Make (struct - let start_addr = 0xb0 + let start = 0xb0 end)) module Devices = Uxn.Device.Compose (Uxn.Device.Compose (System) (Console)) (File) -let print_stack ~name (Machine.Stack { data; sp }) = - Fmt.epr "%s: @[%a@]@." name - (Fmt.on_bytes (Fmt.octets ())) - (Bytes.sub data 0 sp) - let run m pc = let dev = Machine.dev m in try Machine.dispatch ~trace m pc with | effect Machine.Trace (pc, instr, args), k -> if trace then begin - Fmt.epr "PC = %04x | %6s %a@." pc (Instr.to_string instr) - (Fmt.list ~sep:(Fmt.any " ") (Fmt.fmt "%02x")) - args; + Printf.eprintf "PC = %04x %6s %s\n" pc (Instr.to_string instr) + (List.map (Format.sprintf "%02x") args |> String.concat " "); Out_channel.flush stderr end; continue k () @@ -49,7 +43,7 @@ let run m pc = let main () = if Array.length Sys.argv < 2 then ( - Fmt.epr "usage: uxnemu file.rom ...\n"; + Printf.eprintf "usage: uxnemu file.rom ...\n"; exit 1); let code = @@ -92,11 +86,6 @@ let main () = done with Exit -> console_input 0 4 end; - - if trace then begin - print_stack ~name:"wst" (Machine.wst mach); - print_stack ~name:"rst" (Machine.rst mach) - end; exit (Bytes.get_uint8 dev 0x0f land 0x7f) let _ = main () diff --git a/lib/Machine.ml b/lib/Machine.ml index 783b94b..4450ce4 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -5,7 +5,10 @@ open Effect type stack = Stack of { data : bytes; mutable sp : int } type mode = Mode of { short : bool; keep : bool; mutable temp : int } -let stack_create () = Stack { data = Bytes.create 256; sp = 0 } +let stack_create () = + let data = Bytes.create 256 in + Bytes.unsafe_fill data 0 256 '\x00'; + Stack { data; sp = 0 } let peek (Mode { short; keep; temp }) (Stack { data; sp }) : int = let amt = if short then 2 else 1 in @@ -36,13 +39,6 @@ let pushbyte (Mode m) s v = m.temp <- temp [@@inline] -let pushshort (Mode m) s v = - let m' = Mode { m with short = true } in - push m' s v; - let (Mode { temp; _ }) = m' in - m.temp <- temp -[@@inline] - let popbyte (Mode m) s = let m' = Mode { m with short = false } in let r = pop m' s in @@ -75,9 +71,6 @@ type _ Effect.t += | DEI : ([ `Byte | `Short ] * int) -> int Effect.t | DEO : (int * int) -> unit Effect.t | Trace : (int * Instr.t * int list) -> unit Effect.t - | Breakpoint : int -> unit Effect.t - -type machine_state = Break | Next of int let ram (Machine { data; _ }) = data let dev (Machine { dev; _ }) = dev diff --git a/lib/Machine.mli b/lib/Machine.mli index f34d44b..8bce13f 100644 --- a/lib/Machine.mli +++ b/lib/Machine.mli @@ -5,10 +5,6 @@ val stack_create : unit -> stack val peek : mode -> stack -> int val pop : mode -> stack -> int val push : mode -> stack -> int -> unit -val pushbyte : mode -> stack -> int -> unit -val pushshort : mode -> stack -> int -> unit -val popbyte : mode -> stack -> int -val popshort : mode -> stack -> int type machine @@ -17,14 +13,11 @@ val dev : machine -> bytes val wst : machine -> stack val rst : machine -> stack -type machine_state = Break | Next of int - type _ Effect.t += | BRK : int Effect.t | DEI : ([ `Byte | `Short ] * int) -> int Effect.t | DEO : (int * int) -> unit Effect.t | Trace : (int * Instr.t * int list) -> unit Effect.t - | Breakpoint : int -> unit Effect.t val create : string -> machine val dispatch : ?trace:bool -> machine -> int -> 'a diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml index d14ffc7..89b131c 100644 --- a/lib/Varvara/File.ml +++ b/lib/Varvara/File.ml @@ -5,24 +5,21 @@ type file_state = | Dir_read of Unix.dir_handle * string (* dir_handle, filepath *) | Dir_write -type file_device = { +type state = { mutable filepath : string option; mutable state : file_state; mutable length : int; } module type ADDR = sig - val start_addr : int + val start : int end -module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = file_device = -struct - type state = file_device +module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct + type nonrec state = state let state = { filepath = None; state = Idle; length = 0 } - - let can_handle port = - port >= Addr.start_addr && port <= Addr.start_addr + 0x0f + let can_handle port = port >= Addr.start && port <= Addr.start + 0x0f let read_cstring ram addr = let buf = Buffer.create 256 in @@ -204,17 +201,15 @@ struct let open Uxn in let ram = Machine.ram mach in let dev = Machine.dev mach in - let with_success result = - file_success dev (Addr.start_addr + 0x02) result - in - match port - Addr.start_addr with + let with_success result = file_success dev (Addr.start + 0x02) result in + match port - Addr.start with | 0x0a -> state.length <- value | 0x04 -> file_stat (Machine.ram mach) value state.length |> with_success | 0x06 -> file_delete () |> with_success | 0x08 -> file_init (Machine.ram mach) value |> with_success | 0x0c -> file_read (Machine.ram mach) value state.length |> with_success | 0x0e -> - let append = Bytes.get_uint8 dev (Addr.start_addr + 0x07) in + let append = Bytes.get_uint8 dev (Addr.start + 0x07) in file_write ram value state.length append |> with_success | _ -> () end diff --git a/lib/Varvara/System.ml b/lib/Varvara/System.ml index 58ab18f..047c3f5 100644 --- a/lib/Varvara/System.ml +++ b/lib/Varvara/System.ml @@ -9,9 +9,13 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct let can_handle port = port >= 0x00 && port <= 0x0f let print_stack ~name (Machine.Stack { data; sp }) = - Fmt.epr "%s: @[%a@]@." name - (Fmt.on_bytes (Fmt.octets ())) - (Bytes.sub data 0 sp) + Printf.eprintf "%s " name; + for i = sp - 8 to sp - 1 do + Printf.eprintf "%02x%s" + (Bytes.get_uint8 data (i land 0xff)) + (if i land 0xff == 0xff then "|" else " ") + done; + Printf.eprintf "<%02x\n" sp let get_bank mach bank = if bank = 0 then Machine.ram mach diff --git a/lib/Varvara/dune b/lib/Varvara/dune index f7de2ae..600c2de 100644 --- a/lib/Varvara/dune +++ b/lib/Varvara/dune @@ -1,3 +1,3 @@ (library (name varvara) - (libraries uxn fmt unix)) + (libraries uxn unix)) diff --git a/utils/drifblim.tal b/utils/drifblim.tal new file mode 100644 index 0000000..bc48d63 --- /dev/null +++ b/utils/drifblim.tal @@ -0,0 +1,811 @@ +( usage: drifblim.rom input.tal output.rom ) + +|00 @System/vector $2 &expansion $2 &wst $1 &rst $1 &metadata $2 &r $2 &g $2 &b $2 &debug $1 &state $1 +|10 @Console/vector $2 &read $1 &pad $4 &type $1 &write $1 &error $1 +|a0 @File/vector $2 &success $1 &success-lb $1 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2 + +|000 + + @src/buf $3f &cap $1 + @dst/buf $3f &cap $1 + @scope/buf $3f &cap $1 + @token/buf $3f &cap $1 + +|100 + +@on-reset ( -> ) + ;meta #06 DEO2 + ;dict/reset scope/ + ;src/on-console + ( >> ) + +@bind ( vector* -> ) + .Console/vector DEO2 + [ LIT2 03 -Console/type ] DEI AND ?{ + ;dict/usage err/ + [ LIT2 01 -System/state ] DEO } + BRK + +@src/on-console ( -> ) + [ LIT2 02 -Console/type ] DEI LTH ?{ + .Console/read DEI [ LIT2 -&cap &ptr -&buf ] INCk ,&ptr STR + NEQk ?{ ;dict/exceeded ;&buf ;dict/Path err/ } + NIP STZ + BRK } + ( | src -> dst ) + ;dst/on-console !bind + +@dst/on-console ( -> ) + [ LIT2 02 -Console/type ] DEI LTH ?{ .Console/read DEI / + BRK } + ( | assemble ) + ;src/buf assembly/ + assembly/ + BRK + +@dst/ ( c -- ) + [ LIT2 -&cap &ptr -&buf ] INCk ,&ptr STR + NEQk ?{ ;dict/exceeded ;&buf ;dict/Path err/ } + NIP STZ + JMP2r + +@dst/ ( str* -- ) + LDAk DUP ?{ POP POP2 JMP2r } + / + INC2 !/ + +@err/ ( c -- ) + #19 DEO + JMP2r + +@runes/concat INC2 + ( >> ) + +@assembly/ ( f* -- ) + .File/name DEO2 + #0001 .File/length DEO2 + token/ + #0000 + &>s + .System/state DEI ?&end + ;&c .File/read DEO2 + .File/success-lb DEI ?{ + ORAk ?{ ;dict/invalid ;src/buf ;dict/File err/ } + &end ( i* -- ) + POP2 JMP2r } + INC2 [ LIT &c $1 ] token/ !&>s + +@rom/ ( byte addr* -- ) + ,&dst STR2 + ,&v STR + ;&mmu-put .System/expansion DEO2 + JMP2r + + &mmu-put [ 00 0001 0001 &dst $2 &v $1 ] + &mmu-get [ 01 0001 0001 &src $2 0000 =&buf ] &buf $1 + +@rom/ ( -- ) + ;dict/assembled err/ + #20 err/ + ;dst/buf err/ + ;dict/in err/ + ;head/length LDA2 DUP2 #0100 SUB2 err/ + ;dict/bytes err/ + ( | emit rom ) + ;dst/buf .File/name DEO2 + #0001 .File/length DEO2 + #0100 + &>ler + DUP2 ,&src STR2 + ;&mmu-get .System/expansion DEO2 + ;&buf .File/write DEO2 + INC2 GTH2k ?&>ler + POP2 POP2 + ( | emit sym ) + ;dict/sym-ext dst/ + ;dst/buf .File/name DEO2 + ;syms/ptr LDA2 ;syms/mem + &>les + #0002 .File/length DEO2 + DUP2 .File/write DEO2 + #0003 ADD2 DUP2 str/cap SWP2k SUB2 .File/length DEO2 + SWP2 .File/write DEO2 + GTH2k ?&>les + POP2 POP2 JMP2r + +@dict/usage "usage: 20 "drifblim.rom 20 "in.tal 20 "out.rom 0a $1 + &Path "Path $1 + &File "File $1 + &sym-ext ".sym $1 + +@meta $1 + ( name ) "Drifblim 0a + ( desc ) "Uxntal 20 "Assembler 0a + ( auth ) "By 20 "Devine 20 "Lu 20 "Linvega 0a + ( date ) "25 20 "Nov 20 "2025 $2 + + + +( Core ) + +@assembly/ ( -- ) + ( cap ) #0a token/ + ,&mode LDR2 ;comment/assemble NEQ2 ?{ + ( ! ) ;dict/open ;dict/trail ;dict/Comment err/ } + ,&mode LDR2 ;macros/assemble NEQ2 ?{ + ( ! ) ;dict/open ;dict/trail ;dict/Macro err/ } + .System/state DEI ?{ + refs/ + .System/state DEI ?{ + [ LIT2 80 -System/state ] DEO !syms/ } } + JMP2r + +@assembly/apply ( t* -- ) + LDZk ?{ POP2 JMP2r } + [ LIT2 &mode =standard/assemble ] JMP2 + +( +@|Standard ) + +@standard/ ( -- ) + ;&assemble ;assembly/mode STA2 + JMP2r + +@standard/assemble ( t* -- ) + ( hex ) str/is-hex ?rom/ + ( opc ) opcodes/is-opcode ?rom/ + LDZk runes/find INC2k ORA ?{ + POP2 + ( mac ) DUP2 macros/find-name INC2k ORA ?macros/ + POP2 + ( imm ) !runes/litjsi } + INC2 LDA2 JMP2 + +( +@|Comment ) + +@comment/ ( t* -- ) + POP2 ;&assemble ;assembly/mode STA2 + [ LIT2 01 _&depth ] STR + JMP2r + +@comment/assemble ( t* -- ) + LDA2 DUP2 [ LITr &depth $1 ] + ( a ) LIT2 "( $1 EQU2 [ STH ADDr ] + ( b ) LIT2 ") $1 EQU2 [ STH SUBr ] + ( . ) STHkr LITr _&depth STRr + ?{ !standard/ } + JMP2r + +( +@|Macros ) + +@macros/ ( t* -- ) + name/ + / + #00 / + ;&walk ;assembly/mode STA2 + JMP2r + + &walk ( t* -- ) + LDA2 [ LIT2 "{ $1 ] NEQ2 ?{ + ;&assemble ;assembly/mode STA2 + [ LIT2 01 _&depth ] STR } + JMP2r + +@macros/assemble ( t* -- ) + LDA2k DUP2 [ LITr &depth $1 ] + ( a ) LIT "{ EQU SWP LIT "{ EQU ORA [ STH ADDr ] + ( b ) LIT2 "} $1 EQU2 [ STH SUBr ] + ( . ) STHkr LITr _&depth STRr + ?{ POP2 #00 / !standard/ } + / + #20 !/ + +@macros/ ( t* -- ) + ;/ !hof/ + +@macros/ ( byte -- ) + [ LIT2 &ptr =&mem ] INC2k + ( | check overflow ) + DUP2 ;&memend LTH2 ?{ + ( ! ) ;dict/exceeded ;dict/Macros err/ } + ,&ptr STR2 + STA + JMP2r + +@macros/find-name ( name* -- * ) + STH2 + ,&ptr LDR2 ;&mem + &>lf + DUP2 STH2kr str/cmp ?{ + str/cap str/cap GTH2k ?&>lf + POP2 #ffff } + NIP2 POP2r JMP2r + +@macros/ ( t* macro* -- ) + NIP2 token/ + str/cap ;token/ !hof/ + +( +@|Token ) + +@token/ ( -- ) + [ LIT2 -&buf _&ptr ] STR + [ LIT2 00 -&buf ] STZ + JMP2r + +@token/ ( c -- ) + DUP #20 GTH ?{ + ;&buf assembly/apply #0a NEQ ?{ + [ LIT2 &line 0001 ] INC2 ,&line STR2 } + !/ } + [ LIT2 00 &ptr -&buf ] INCk + ( | check overflow ) + DUP .&cap LTH ?{ + ( ! ) ;dict/exceeded ;dict/Name err/ } + ,&ptr STR + STZ2 + JMP2r + +( +@|Scope ) + +@scope/ ( c -- ) + [ LIT2 00 &ptr -&buf ] INCk + ( | check overflow ) + DUP .&cap LTH ?{ + ( ! ) ;dict/exceeded ;dict/Symbol err/ } + ,&ptr STR + STZ2 + JMP2r + +@scope/ ( name* -- ) + [ LIT2 -&buf _&ptr ] STR + &>w + LDAk [ LIT "/ ] EQU ?{ + LDAk / + INC2 LDAk ?&>w } + POP2 ,&ptr LDR ,&anchor STR + JMP2r + +@scope/make-name ( name* -- scope/label* ) + INC2 [ LIT2 &anchor $1 _&ptr ] STR + [ LIT "/ ] / + ;&buf SWP2 ;/ !hof/ + +( +@|Runes ) + +@runes/find ( char -- * ) + STH + ;&lut + &>w + LDAk STHkr EQU ?{ + #0003 ADD2 LDAk ?&>w + POP2 #ffff } + POPr JMP2r + +@runes/ignore ( t* -- ) + POP2 JMP2r + + &lambda ( t* -- ) + POP2 !lambda/pop + + &coment ( t* -- ) + !comment/ + + ¯os ( t* -- ) + /req-name !macros/ + + &padabs ( t* -- ) + /req-name syms/find-addr !head/ + + &padrel ( t* -- ) + /req-name syms/find-addr !head/ + + &toplab ( t* -- ) + /req-name DUP2 scope/ !syms/ + + &sublab ( t* -- ) + scope/make-name !syms/ + + &litrel ( t* -- ) + #80 rom/ &rawrel /req-name refs/get-rel !rom/ + + &litzep ( t* -- ) + #80 rom/ &rawzep /req-name refs/get-abs !rom/ + + &litabs ( t* -- ) + #a0 rom/ &rawabs /req-name refs/get-abs2 !rom/ + + &litjci ( t* -- ) + /req-name #20 !rom/ + + &litjmi ( t* -- ) + /req-name #40 !rom/ + + &litjsi ( t* -- ) + #60 !rom/ + + &lithex ( t* -- ) + /req-name !rom/ + + &rawstr ( t* -- ) + /req-name !rom/ + +@runes/req-name ( str* -- str1* ) + INC2 LDAk #20 GTH ?{ ;dict/invalid ;dict/Name !err/ } + JMP2r + +@runes/lut [ + "| =&padabs "$ =&padrel + "@ =&toplab "& =&sublab + ", =&litrel "_ =&rawrel + ". =&litzep "- =&rawzep + "; =&litabs "= =&rawabs + "! =&litjmi "? =&litjci + "# =&lithex "" =&rawstr + "} =&lambda "~ =&concat + "( =&coment ") =&ignore + "[ =&ignore "] =&ignore "% =¯os ] $1 + +( +@|Opcodes ) + +@opcodes/is-opcode ( str* -- str* bool ) + DUP2 /parse #00 NEQ STH + DUP2 ;&brk str/cmp STHr ORA JMP2r + +@opcodes/parse ( str* -- byte ) + [ LIT2r 1f00 ] ;&lut + &>w1 + SWP2k #0003 SWP2 mem/cmp ?{ + INCr #0003 ADD2 LDAk ?&>w1 + POP2 POP2 POP2r #00 JMP2r } + POP2 + ( mask ) ANDr + ( litk ) LDA2k [ LIT2 "LI ] EQU2 #70 SFT [ STH ORAr ] + ( move ) #0003 ADD2 + &>w2 + LDAk #21 LTH ?{ + ( | parse modes ) + LDAk [ LIT "2 ] NEQ ?{ LITr 20 !&r } + LDAk [ LIT "r ] NEQ ?{ LITr 40 !&r } + LDAk [ LIT "k ] NEQ ?{ LITr 80 !&r } + POP2 POPr #00 JMP2r + &r ORAr INC2 !&>w2 } + POP2 STHr JMP2r + +@opcodes/lut [ + "LIT "INC "POP "NIP "SWP "ROT "DUP "OVR + "EQU "NEQ "GTH "LTH "JMP "JCN "JSR "STH + "LDZ "STZ "LDR "STR "LDA "STA "DEI "DEO + "ADD "SUB "MUL "DIV "AND "ORA "EOR "SFT ] + &brk "BRK $1 + +( +@|Lambda ) + +@lambda/make-name ( token* -- name* ) + POP2 [ LIT2 &count $2 ] INC2k ,&count STR2 + DUP2 [ LIT2 &ptr =&mem ] INC2k INC2 ,&ptr STR2 + STA2 + ( >> ) + +@lambda/name ( id* -- str* ) + /name-part ROT /name-part ,&id1 STR2 + ,&id2 STR2 + ;&sym JMP2r + +@lambda/name-part ( id -- hexchar hexchar ) + DUP #04 SFT hexc SWP !hexc + +@lambda/pop ( -- ) + ,&ptr LDR2 #0002 SUB2 LDA2k /name syms/ + ,&ptr STR2 + JMP2r + &sym cebb + &id1 ".. + &id2 ".. 00 + +( +@|Name ) + +@name/ ( name* -- name* ) + ( not hex ) str/is-hex ?&fail + ( not lambda ) LDAk LIT "{ EQU ?&fail + ( not runic ) LDAk runes/find INC2 ORA ?&fail + ( dup macros ) DUP2 macros/find-name INC2 ORA ?&dup + ( dup symbol ) DUP2 syms/find-name INC2 ORA ?&dup + ( not opcode ) opcodes/is-opcode [ JMP JMP2r ] + &fail ( -- ) + ;dict/invalid ;dict/Name !err/ + + &dup ( -- ) + ;dict/duplicate ;dict/Name !err/ + +@name/unpack ( name* -- name* ) + LDAk [ LIT "{ ] EQU ?lambda/make-name + LDAk [ LIT "/ ] EQU ?scope/make-name + LDAk [ LIT "& ] EQU ?scope/make-name + JMP2r + +( +@|Syms ) + +@syms/ ( name* -- ) + DUP2 /find-name INC2k ORA ?{ + POP2 ;&ptr LDA2 refs/ + .SymType/declared head/get !/ } + ( | name* sym* -- ) + NIP2 DUP2 refs/ + /is-declared ?{ head/get OVR2 STA2 !/ } + POP2 + ( ! ) ;dict/duplicate ;dict/Symbol !err/ + +@syms/ ( name* type addr* -- ) + ( hb ) SWP / + ( lb ) / + ( type ) / + name/ + ;/ hof/ + #00 + ( >> ) + +@syms/ ( byte -- ) + [ LIT2 &ptr =&mem ] INC2k + ( | check overflow ) + DUP2 ;refs/ptr LDA2 LTH2 ?{ + ( ! ) ;dict/exceeded ;dict/Symbols err/ } + ,&ptr STR2 + STA + JMP2r + +@syms/find-name ( name* -- * ) + STH2 + ,&ptr LDR2 ;&mem + &>lfn + DUP2 #0003 ADD2 STH2kr str/cmp ?{ + #0003 ADD2 str/cap GTH2k ?&>lfn + POP2 #ffff } + NIP2 POP2r JMP2r + +@syms/find-alloc ( name* -- * ) + DUP2 /find-name INC2k ORA ?{ + ( null* .. next* ) POP2 ,&ptr LDR2 + ( alloc ) SWP2 .SymType/used #ffff !/ } + NIP2 JMP2r + +@syms/find-addr ( name* -- * ) + str/is-hex ?str/hex + name/unpack /find-name /is-defined ?{ + ( ! ) ;dict/invalid ;dict/Symbol err/ } + /use LDA2 JMP2r + +@syms/ ( -- ) + ;&ptr LDA2 ;&mem + &>ls + EQU2k ?{ + /is-used ?{ + LDA2k #0100 EQU2 ?{ + DUP2 #0003 ADD2 LDAk [ LIT "A ] SUB #1a LTH ?{ + ;dict/unused err/ + DUP2 err/ + #0a err/ } + POP2 } } + #0003 ADD2 str/cap !&>ls } + POP2 POP2 !rom/ + +@syms/byte-distance ( addr* -- addr* ) + DUP2 #0080 ADD2 POP ?{ JMP2r } + ( ! ) ;dict/too-far ;dict/Symbol !err/ + +@syms/is-defined ( sym* -- sym* t ) + INC2k ORA ?{ #00 JMP2r } + ( >> ) + +@syms/is-declared ( sym* -- sym* t ) + INC2k INC2 LDA .SymType/declared AND JMP2r + +@syms/is-used ( sym* -- sym* t ) + INC2k INC2 LDA .SymType/used AND JMP2r + +@syms/use ( sym* -- sym* ) + INC2k INC2 STH2k LDA .SymType/used ORA STH2r STA + JMP2r + +@syms/ ( sym* -- ) + INC2 INC2 STH2k LDA .SymType/declared ORA STH2r STA + JMP2r + +( +@|References ) + +@refs/get-type ( token* type* -- addr* ) + ,&type STR2 + name/unpack syms/find-alloc syms/is-declared ?{ + DUP2 head/get ,&ptr LDR2 #000a SUB2 ,&ptr STR2 + ( addr* ) / + ( symbol* ) / + ( type-fn* ) [ LIT2 &type $2 ] / + ( scope* ) [ LIT2 &scope $2 ] / + ( line* ) ;token/line LDA2 / + ,&ptr LDR2 #000a SUB2 ,&ptr STR2 } + ( | mark as used ) + syms/use LDA2 JMP2r + +@refs/ ( value* -- ) + SWP / + ( >> ) + +@refs/ ( byte -- ) + [ LIT2 &ptr =&memend ] INC2k + ( | check overflow ) + DUP2 ;syms/ptr LDA2 GTH2 ?{ + ( ! ) ;dict/exceeded ;dict/References err/ } + ,&ptr STR2 + STA + JMP2r + +@refs/get-abs ( label* -- addr ) + ;&handle-abs /get-type NIP JMP2r + +@refs/get-abs2 ( label* -- addr* ) + ;&handle-abs2 !/get-type + +@refs/get-rel ( label* -- distance ) + ;&handle-rel /get-type INC2k ORA ?{ + ( undefined ) POP2 #00 JMP2r } + head/get /get-distance syms/byte-distance NIP JMP2r + +@refs/get-rel2 ( label* -- distance* ) + ;&handle-rel2 /get-type head/get + ( >> ) + +@refs/get-distance ( a* b* -- distance* ) + INC2 INC2 SUB2 JMP2r + +@refs/ ( -- ) + ,&ptr LDR2 ;&memend + &>l + EQU2k ?{ + #000a SUB2 DUP2 ;err/ref STA2 + DUP2k #0004 ADD2 LDA2 JSR2 !&>l } + POP2 POP2 JMP2r + +@refs/resolve-sym ( ref* -- ref* sym/addr* ) + LDA2k head/ + ( ref* sym* ) INC2k INC2 LDA2 + ( ref* sym/addr* ) LDA2 + ( ref* sym/addr* ) INC2k ORA ?{ + ( ! ) ;dict/invalid !err/ } + ( ref* sym/addr* ) JMP2r + +@refs/handle-abs ( ref* -- ) + /resolve-sym NIP2 NIP !rom/ + +@refs/handle-abs2 ( ref* -- ) + /resolve-sym NIP2 !rom/ + +@refs/handle-rel ( ref* -- ) + /resolve-sym SWP2 LDA2 /get-distance /byte-distance NIP !rom/ + +@refs/handle-rel2 ( ref* -- ) + /resolve-sym SWP2 LDA2 /get-distance !rom/ + +@refs/byte-distance ( addr* -- addr* ) + DUP2 #0080 ADD2 POP ?{ JMP2r } + ( ! ) ;dict/too-far !err/ + +@refs/ ( sym* -- ) + DUP2 #0003 ADD2 LDA2 #cebb NEQ2 ?{ POP2 JMP2r } + ;refs/scope STA2 + JMP2r + +( +@|Rom ) + +@rom/ ( str* -- ) + ;/ !hof/ + +@rom/ ( str* -- ) + opcodes/parse !/ + +@rom/ ( str* -- ) + str/len #02 NEQ #50 SFT #80 ORA / + ( >> ) + +@rom/ ( str* -- ) + str/is-hex #00 EQU ?{ + str/len DUP #02 NEQ ?{ POP str/hex NIP !/ } + #04 NEQ ?{ str/hex !/ } } + POP2 ;dict/invalid ;dict/Number !err/ + +@rom/ ( str* opc -- ) + / + refs/get-rel2 + ( >> ) + +@rom/ ( short* -- ) + SWP / + ( >> ) + +@rom/ ( byte -- ) + head/get-inc + ( | test zero-page ) + OVR ?{ + POP2 POP + ( ! ) ;dict/zero-page ;dict/Writing !err/ } + !rom/ + +@head/get-inc ( -- addr* ) + [ LIT2 &addr 0100 ] INC2k ,&addr STR2 + INC2k [ LIT2 &length 0100 ] LTH2 ?{ INC2k ,&length STR2 } + JMP2r + +@head/get ( -- addr* ) + ,&addr LDR2 JMP2r + +@head/ ( addr* -- ) + /get ADD2 + ( >> ) + +@head/ ( addr* -- ) + ,&addr STR2 + JMP2r + +( +@|Stdlib ) + +@hof/ ( data* byte-fn* -- ) + STH2 + &>w + LDAk DUP ?{ POP POP2 POP2r JMP2r } + STH2kr JSR2 INC2 !&>w + +@hexc ( hex -- char ) + #0f AND #0a LTHk ?{ + SUB [ LIT "a ] ADD JMP2r } + POP [ LIT "0 ] ADD JMP2r + +@chex ( addr* -- addr* ) + LDAk + ( dec ) [ LIT "0 ] SUB DUP #09 GTH [ JMP JMP2r ] + ( hex ) #27 SUB DUP #0a SUB #05 GTH [ JMP JMP2r ] + ( nil ) POP #ff JMP2r + +@str/hex ( str* -- value* ) + [ LIT2r 0000 ] + &>wh + [ LITr 40 ] SFT2r chex [ LITr 00 ] STH + ADD2r INC2 LDAk ?&>wh + POP2 STH2r JMP2r + +@str/len ( str* -- str* length ) + DUP2k /cap SWP2 INC2 SUB2 NIP JMP2r + +@str/is-hex ( str* -- str* f ) + DUP2 + &>wih + chex INC ?{ LDA #00 EQU JMP2r } + INC2 !&>wih + +@str/cap ( str* -- end* ) + LDAk ?{ INC2 JMP2r } + INC2 !/cap + +@str/cmp ( a* b* -- bool ) + DUP2k /cap SWP2 SUB2 SWP2 + ( >> ) + +@mem/cmp ( a* length* b* -- t ) + STH2 + OVR2 ADD2 SWP2 + &>l + EQU2k ?{ + LDAk LDAkr STHr NEQ ?{ INC2 INC2r !&>l } } + POP2r EQU2 JMP2r + +( +@|Error ) + +@err/ ( adj* topic* -- ) + .System/state DEI ?{ + [ LIT2 01 -System/state ] DEO + / + #20 / + / + ;dict/spacer / + ;token/buf / + ;token/line LDA2 ;scope/buf !/ } + POP2 POP2 JMP2r + +@err/ ( adj* -- ) + .System/state DEI ?{ + [ LIT2 01 -System/state ] DEO + ;dict/Reference / + #20 / + / + ;dict/spacer / + [ LIT2 &ref $2 ] INC2k INC2 LDA2 #0003 ADD2 / + DUP2 #0008 ADD2 LDA2 SWP2 #0006 ADD2 LDA2 #0003 ADD2 !/ } + POP2 JMP2r + +@err/ ( line* scope* -- ) + ;dict/in / + / + LIT ": / + / + #0a / + JMP2r + +@err/ ( adj* keyword* topic* -- ) + .System/state DEI ?{ + [ LIT2 01 -System/state ] DEO + / + #20 / + SWP2 / + ;dict/spacer / + / + #0a / + JMP2r } + POP2 POP2 POP2 JMP2r + +@err/ ( str* -- ) + ;/ !hof/ + +@err/ ( short* -- ) + [ LIT2r ff00 ] + &>read + #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ORAk ?&>read + POP2 + &>write + NIP #30 ADD / + OVRr ADDr STHkr ?&>write + POP2r JMP2r + +@dict/assembled "Assembled $1 &in 20 "in 20 $1 &bytes 20 "bytes. 0a $1 + &unused "-- 20 "Unused + &spacer ": 20 $1 + &References "References $1 + &Reference "Reference $1 + &Symbols "Symbols $1 + &Symbol "Symbol $1 + &Macros "Macros $1 + &Macro "Macro $1 + &Name "Name $1 + &Number "Number $1 + &Comment "Comment $1 + &Writing "Writing $1 + &exceeded "exceeded $1 + &invalid "invalid $1 + &duplicate "duplicate $1 + &too-far "too 20 "far $1 + &zero-page "zero-page $1 + &open "open $1 + &trail ".. $1 + &reset "RESET $1 + +( +@|Buffers ) + +@lambda/mem $200 + +@macros/mem ( name\0, value\0 ) + $1000 &memend + +@syms/mem ( addr*, SymType, name\0 ) + $7000 &memend +|syms/mem @refs/mem ( addr*, symbol*, type-fn*, scope*, line* ) + $7000 &memend + +@rom/mem ( zeropage ) + $100 + &output +( +@|Enums ) + + +|00 @SymType/empty $1 &used $1 &declared + From aa14e6cf12aea290225906eb1a78d5b3a1939dee Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 15:52:29 -0300 Subject: [PATCH 06/10] remove Fmt from shell.nix --- shell.nix | 1 - 1 file changed, 1 deletion(-) diff --git a/shell.nix b/shell.nix index e6ad57a..d67efc2 100644 --- a/shell.nix +++ b/shell.nix @@ -13,6 +13,5 @@ pkgs.mkShell { ocamlPackages.ocamlformat ocamlPackages.merlin ocamlPackages.ocaml-lsp - ocamlPackages.fmt ]; } From 9e64f449809f72023def8c15961fa9843ccc65b1 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 18:47:24 -0300 Subject: [PATCH 07/10] small optimizations --- lib/Machine.ml | 94 ++++++++++++++++++++++++++------------------------ 1 file changed, 49 insertions(+), 45 deletions(-) diff --git a/lib/Machine.ml b/lib/Machine.ml index 4450ce4..27d5c30 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -87,54 +87,58 @@ let create code = let dispatch ?(trace = false) (Machine m) (pc : int) = let pc = ref pc in + let trace op l = + if trace then + let instr = Instr.of_int op in + perform (Trace (!pc, instr, l)) + in while true do - pc := !pc land 0xffff; - - let op = Bytes.get_uint8 m.data !pc in - let instr = Instr.of_int op in - let trace l = if trace then perform (Trace (!pc, instr, l)) in - + let op = Bytes.get_uint8 m.data (!pc land 0xffff) in pc := (!pc + 1) land 0xffff; + let short = op land 0x20 <> 0 in + let keep = op land 0x80 <> 0 in + let return = op land 0x40 <> 0 in + let opcode = op land 0x1f in + match op with | 0x00 -> pc := perform BRK | 0x20 (* JCI *) -> let cond = pop1 m.stack in let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace [ Bytes.get_uint16_be m.data !pc; cond ]; + trace op [ Bytes.get_uint16_be m.data !pc; cond ]; if cond != 0 then pc := !pc + addr + 2 else pc := !pc + 2 | 0x40 (* JMI *) -> let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace [ Bytes.get_uint16_be m.data !pc ]; + trace op [ Bytes.get_uint16_be m.data !pc ]; pc := !pc + addr + 2 | 0x60 (* JSI *) -> let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace [ Bytes.get_uint16_be m.data !pc ]; + trace op [ Bytes.get_uint16_be m.data !pc ]; push2 m.callstack (!pc + 2); pc := !pc + addr + 2 | 0x80 (* LIT *) -> let lit = Bytes.get_uint8 m.data !pc in - trace [ lit ]; + trace op [ lit ]; push1 m.stack lit; pc := !pc + 1 | 0xa0 (* LIT2 *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in - trace [ lit ]; + trace op [ lit ]; push2 m.stack lit; pc := !pc + 2 | 0xc0 (* LITr *) -> let lit = Bytes.get_uint8 m.data !pc in - trace [ lit ]; + trace op [ lit ]; push1 m.callstack lit; pc := !pc + 1 | 0xe0 (* LIT2r *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in - trace [ lit ]; + trace op [ lit ]; push2 m.callstack lit; pc := !pc + 2 | _ -> begin - let (Instruction { short; keep; return; opcode }) = Instr.of_int op in let stk = if return then m.callstack else m.stack in let stk' = if return then m.stack else m.callstack in let mode = @@ -143,166 +147,166 @@ let dispatch ?(trace = false) (Machine m) (pc : int) = match[@warning "-8"] opcode with | 0x01 (* INC *) -> let r = pop mode stk in - trace [ r ]; + trace op [ r ]; push mode stk (r + 1) - | 0x02 (* POP *) -> trace [ pop mode stk ] + | 0x02 (* POP *) -> trace op [ pop mode stk ] | 0x03 (* NIP *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk b | 0x04 (* SWP *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk b; push mode stk a | 0x05 (* ROT *) -> let c = pop mode stk in let b = pop mode stk in let a = pop mode stk in - trace [ a; b; c ]; + trace op [ a; b; c ]; push mode stk b; push mode stk c; push mode stk a | 0x06 (* DUP *) -> let a = pop mode stk in - trace [ a ]; + trace op [ a ]; push mode stk a; push mode stk a | 0x07 (* OVR *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk a; push mode stk b; push mode stk a | 0x08 (* EQU *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; pushbyte mode stk (if a = b then 1 else 0) | 0x09 (* NEQ *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; pushbyte mode stk (if a != b then 1 else 0) | 0x0a (* GTH *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; pushbyte mode stk (if a > b then 1 else 0) | 0x0b (* LTH *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; pushbyte mode stk (if a < b then 1 else 0) | 0x0c (* JMP *) -> let addr = pop mode stk in - trace [ addr ]; + trace op [ addr ]; if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0d (* JCN *) -> let addr = pop mode stk in let cond = popbyte mode stk in - trace [ cond; addr ]; + trace op [ cond; addr ]; if cond != 0 then if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0e (* JSR *) -> push2 m.callstack !pc; let addr = pop mode stk in - trace [ addr ]; + trace op [ addr ]; if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0f (* STH *) -> let a = pop mode stk in - trace [ a ]; + trace op [ a ]; push mode stk' a | 0x10 (* LDZ *) -> let addr = popbyte mode stk in - trace [ addr ]; + trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap m.data addr else Bytes.get_uint8 m.data addr) | 0x11 (* STZ *) -> let addr = popbyte mode stk in let v = pop mode stk in - trace [ v; addr ]; + trace op [ v; addr ]; if short then Util.set_uint16_wrap m.data addr v else Bytes.set_uint8 m.data addr v | 0x12 (* LDR *) -> let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in - trace [ addr ]; + trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr else Bytes.get_uint8 m.data addr) | 0x13 (* STR *) -> let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in let v = pop mode stk in - trace [ v; addr ]; + trace op [ v; addr ]; if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v else Bytes.set_uint8 m.data addr v | 0x14 (* LDA *) -> let addr = popshort mode stk in - trace [ addr ]; + trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr else Bytes.get_uint8 m.data addr) | 0x15 (* STA *) -> let addr = popshort mode stk in let v = pop mode stk in - trace [ v; addr ]; + trace op [ v; addr ]; if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v else Bytes.set_uint8 m.data addr v | 0x16 (* DEI *) -> let port = popbyte mode stk in - trace [ port ]; + trace op [ port ]; push mode stk (perform (DEI ((if short then `Short else `Byte), port))) | 0x17 (* DEO *) -> let port = popbyte mode stk in let value = pop mode stk in - trace [ value; port ]; + trace op [ value; port ]; if short then Util.set_uint16_wrap m.dev port value else Bytes.set_uint8 m.dev port value; perform (DEO (port, value)) | 0x18 (* ADD *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a + b) | 0x19 (* SUB *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a - b) | 0x1a (* MUL *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a * b) | 0x1b (* DIV *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (if b = 0 then 0 else a / b) | 0x1c (* AND *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a land b) | 0x1d (* ORA *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a lor b) | 0x1e (* EOR *) -> let b = pop mode stk in let a = pop mode stk in - trace [ a; b ]; + trace op [ a; b ]; push mode stk (a lxor b) | 0x1f (* SFT *) -> let sft = popbyte mode stk in let value = pop mode stk in - trace [ value; sft ]; + trace op [ value; sft ]; push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4) end done From 56a3398c8f6b18e2e43f8dc420bab591344bde19 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Thu, 18 Dec 2025 18:50:14 -0300 Subject: [PATCH 08/10] housekeeping --- lib/Device.ml | 3 ++- shell.nix | 2 ++ utils/Makefile | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/Device.ml b/lib/Device.ml index bc87443..571246b 100644 --- a/lib/Device.ml +++ b/lib/Device.ml @@ -8,7 +8,8 @@ module type DEVICE = sig val deo : Machine.machine -> int -> int -> unit end -module Compose (D1 : DEVICE) (D2 : DEVICE) : DEVICE = struct +module Compose (D1 : DEVICE) (D2 : DEVICE) : + DEVICE with type state = D1.state * D2.state = struct type state = D1.state * D2.state let state = (D1.state, D2.state) diff --git a/shell.nix b/shell.nix index d67efc2..6b2bc7e 100644 --- a/shell.nix +++ b/shell.nix @@ -4,6 +4,8 @@ pkgs.mkShell { buildInputs = with pkgs; [ + clang-tools + hyperfine xxd uxn ocamlPackages.ocaml diff --git a/utils/Makefile b/utils/Makefile index 7d48a98..6882f8e 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -3,7 +3,7 @@ all: uxnmin drifloon.rom opctest.rom varvara.file.rom clean: - rm -f uxnmin drifloon.rom opctest.rom + rm -f uxnmin *.rom uxnmin: uxnmin.c drifloon.rom: uxnmin From cf31dc55649a8d7e0bed76bac18df52b27104c5d Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Fri, 19 Dec 2025 00:31:36 -0300 Subject: [PATCH 09/10] add datetime device, revise device handling, remove tracing code --- exe/uxnemu.ml | 72 +++++++++++++++++++++++++---------------- lib/Device.ml | 35 ++++---------------- lib/Machine.ml | 49 ++-------------------------- lib/Machine.mli | 3 +- lib/Varvara/Console.ml | 9 +++--- lib/Varvara/Datetime.ml | 34 +++++++++++++++++++ lib/Varvara/File.ml | 19 ++++++++--- lib/Varvara/System.ml | 13 ++++---- 8 files changed, 115 insertions(+), 119 deletions(-) create mode 100644 lib/Varvara/Datetime.ml diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 7b2189a..9939408 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -1,44 +1,54 @@ open Uxn open Effect.Deep -let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG") +let devices_deo = Hashtbl.create 256 +let devices_dei = Hashtbl.create 256 + +let register_device (module D : Device.DEVICE) = + Device.Int_set.iter + (fun port -> Hashtbl.add devices_dei port (module D : Device.DEVICE)) + D.dei_ports; + Device.Int_set.iter + (fun port -> Hashtbl.add devices_deo port (module D : Device.DEVICE)) + D.deo_ports module System = Varvara.System.Make () module Console = Varvara.Console.Make () +module Datetime = Varvara.Datetime.Make () -module File = - Uxn.Device.Compose - (Varvara.File.Make (struct - let start = 0xa0 - end)) - (Varvara.File.Make (struct - let start = 0xb0 - end)) +module File_a = Varvara.File.Make (struct + let start = 0xa0 +end) -module Devices = - Uxn.Device.Compose (Uxn.Device.Compose (System) (Console)) (File) +module File_b = Varvara.File.Make (struct + let start = 0xb0 +end) let run m pc = let dev = Machine.dev m in - try Machine.dispatch ~trace m pc with - | effect Machine.Trace (pc, instr, args), k -> - if trace then begin - Printf.eprintf "PC = %04x %6s %s\n" pc (Instr.to_string instr) - (List.map (Format.sprintf "%02x") args |> String.concat " "); - Out_channel.flush stderr - end; - continue k () + try Machine.dispatch m pc with | effect Machine.BRK, _ -> () - | effect Machine.DEI (`Byte, port), k -> ( - match Devices.dei m port with - | Some v -> continue k v - | None -> continue k (Bytes.get_uint8 dev port)) - | effect Machine.DEI (`Short, port), k -> ( - match Devices.dei2 m port with - | Some v -> continue k v - | None -> continue k (Util.get_uint16_wrap dev port)) + | effect Machine.DEI (`Byte, port), k -> begin + try + let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE) + in + continue k (Device.dei m port) + with Not_found -> continue k (Bytes.get_uint8 dev port) + end + | effect Machine.DEI (`Short, port), k -> begin + try + let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE) + in + continue k (Device.dei2 m port) + with Not_found -> continue k (Util.get_uint16_wrap dev port) + end | effect Machine.DEO (port, value), k -> - if Devices.can_handle port then Devices.deo m port value; + begin try + let module Device = (val Hashtbl.find devices_deo port : Device.DEVICE) + in + Device.deo m port value + with Not_found -> () + end; continue k () let main () = @@ -46,6 +56,12 @@ let main () = Printf.eprintf "usage: uxnemu file.rom ...\n"; exit 1); + register_device (module System : Device.DEVICE); + register_device (module Console : Device.DEVICE); + register_device (module File_a : Device.DEVICE); + register_device (module File_b : Device.DEVICE); + register_device (module Datetime : Device.DEVICE); + let code = In_channel.with_open_bin Sys.argv.(1) (fun i -> In_channel.input_all i) in diff --git a/lib/Device.ml b/lib/Device.ml index 571246b..f538681 100644 --- a/lib/Device.ml +++ b/lib/Device.ml @@ -1,35 +1,12 @@ +module Int_set = Set.Make (Int) + module type DEVICE = sig type state val state : state - val can_handle : int -> bool - val dei : Machine.machine -> int -> int option - val dei2 : Machine.machine -> int -> int option + val dei_ports : Int_set.t + val deo_ports : Int_set.t + val dei : Machine.machine -> int -> int + val dei2 : Machine.machine -> int -> int val deo : Machine.machine -> int -> int -> unit end - -module Compose (D1 : DEVICE) (D2 : DEVICE) : - DEVICE with type state = D1.state * D2.state = struct - type state = D1.state * D2.state - - let state = (D1.state, D2.state) - let can_handle port = D1.can_handle port || D2.can_handle port - - let dei mach port = - match (D1.can_handle port, D2.can_handle port) with - | true, false -> D1.dei mach port - | false, true -> D2.dei mach port - | _ -> None - - let dei2 mach port = - match (D1.can_handle port, D2.can_handle port) with - | true, false -> D1.dei2 mach port - | false, true -> D2.dei2 mach port - | _ -> None - - let deo mach port value = - match (D1.can_handle port, D2.can_handle port) with - | true, false -> D1.deo mach port value - | false, true -> D2.deo mach port value - | _ -> () -end diff --git a/lib/Machine.ml b/lib/Machine.ml index 27d5c30..4796104 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -70,7 +70,6 @@ type _ Effect.t += | BRK : int Effect.t | DEI : ([ `Byte | `Short ] * int) -> int Effect.t | DEO : (int * int) -> unit Effect.t - | Trace : (int * Instr.t * int list) -> unit Effect.t let ram (Machine { data; _ }) = data let dev (Machine { dev; _ }) = dev @@ -85,13 +84,8 @@ let create code = Bytes.blit_string code 0 data 0x100 (String.length code); Machine { data; dev; stack = stack_create (); callstack = stack_create () } -let dispatch ?(trace = false) (Machine m) (pc : int) = +let dispatch (Machine m) (pc : int) = let pc = ref pc in - let trace op l = - if trace then - let instr = Instr.of_int op in - perform (Trace (!pc, instr, l)) - in while true do let op = Bytes.get_uint8 m.data (!pc land 0xffff) in @@ -107,35 +101,28 @@ let dispatch ?(trace = false) (Machine m) (pc : int) = | 0x20 (* JCI *) -> let cond = pop1 m.stack in let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace op [ Bytes.get_uint16_be m.data !pc; cond ]; if cond != 0 then pc := !pc + addr + 2 else pc := !pc + 2 | 0x40 (* JMI *) -> let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace op [ Bytes.get_uint16_be m.data !pc ]; pc := !pc + addr + 2 | 0x60 (* JSI *) -> let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in - trace op [ Bytes.get_uint16_be m.data !pc ]; push2 m.callstack (!pc + 2); pc := !pc + addr + 2 | 0x80 (* LIT *) -> let lit = Bytes.get_uint8 m.data !pc in - trace op [ lit ]; push1 m.stack lit; pc := !pc + 1 | 0xa0 (* LIT2 *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in - trace op [ lit ]; push2 m.stack lit; pc := !pc + 2 | 0xc0 (* LITr *) -> let lit = Bytes.get_uint8 m.data !pc in - trace op [ lit ]; push1 m.callstack lit; pc := !pc + 1 | 0xe0 (* LIT2r *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in - trace op [ lit ]; push2 m.callstack lit; pc := !pc + 2 | _ -> begin @@ -147,166 +134,136 @@ let dispatch ?(trace = false) (Machine m) (pc : int) = match[@warning "-8"] opcode with | 0x01 (* INC *) -> let r = pop mode stk in - trace op [ r ]; push mode stk (r + 1) - | 0x02 (* POP *) -> trace op [ pop mode stk ] + | 0x02 (* POP *) -> ignore (pop mode stk) | 0x03 (* NIP *) -> let b = pop mode stk in - let a = pop mode stk in - trace op [ a; b ]; + ignore (pop mode stk); push mode stk b | 0x04 (* SWP *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk b; push mode stk a | 0x05 (* ROT *) -> let c = pop mode stk in let b = pop mode stk in let a = pop mode stk in - trace op [ a; b; c ]; push mode stk b; push mode stk c; push mode stk a | 0x06 (* DUP *) -> let a = pop mode stk in - trace op [ a ]; push mode stk a; push mode stk a | 0x07 (* OVR *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk a; push mode stk b; push mode stk a | 0x08 (* EQU *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; pushbyte mode stk (if a = b then 1 else 0) | 0x09 (* NEQ *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; pushbyte mode stk (if a != b then 1 else 0) | 0x0a (* GTH *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; pushbyte mode stk (if a > b then 1 else 0) | 0x0b (* LTH *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; pushbyte mode stk (if a < b then 1 else 0) | 0x0c (* JMP *) -> let addr = pop mode stk in - trace op [ addr ]; if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0d (* JCN *) -> let addr = pop mode stk in let cond = popbyte mode stk in - trace op [ cond; addr ]; if cond != 0 then if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0e (* JSR *) -> push2 m.callstack !pc; let addr = pop mode stk in - trace op [ addr ]; if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0f (* STH *) -> let a = pop mode stk in - trace op [ a ]; push mode stk' a | 0x10 (* LDZ *) -> let addr = popbyte mode stk in - trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap m.data addr else Bytes.get_uint8 m.data addr) | 0x11 (* STZ *) -> let addr = popbyte mode stk in let v = pop mode stk in - trace op [ v; addr ]; if short then Util.set_uint16_wrap m.data addr v else Bytes.set_uint8 m.data addr v | 0x12 (* LDR *) -> let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in - trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr else Bytes.get_uint8 m.data addr) | 0x13 (* STR *) -> let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in let v = pop mode stk in - trace op [ v; addr ]; if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v else Bytes.set_uint8 m.data addr v | 0x14 (* LDA *) -> let addr = popshort mode stk in - trace op [ addr ]; push mode stk (if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr else Bytes.get_uint8 m.data addr) | 0x15 (* STA *) -> let addr = popshort mode stk in let v = pop mode stk in - trace op [ v; addr ]; if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v else Bytes.set_uint8 m.data addr v | 0x16 (* DEI *) -> let port = popbyte mode stk in - trace op [ port ]; push mode stk (perform (DEI ((if short then `Short else `Byte), port))) | 0x17 (* DEO *) -> let port = popbyte mode stk in let value = pop mode stk in - trace op [ value; port ]; if short then Util.set_uint16_wrap m.dev port value else Bytes.set_uint8 m.dev port value; perform (DEO (port, value)) | 0x18 (* ADD *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a + b) | 0x19 (* SUB *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a - b) | 0x1a (* MUL *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a * b) | 0x1b (* DIV *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (if b = 0 then 0 else a / b) | 0x1c (* AND *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a land b) | 0x1d (* ORA *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a lor b) | 0x1e (* EOR *) -> let b = pop mode stk in let a = pop mode stk in - trace op [ a; b ]; push mode stk (a lxor b) | 0x1f (* SFT *) -> let sft = popbyte mode stk in let value = pop mode stk in - trace op [ value; sft ]; push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4) end done diff --git a/lib/Machine.mli b/lib/Machine.mli index 8bce13f..81494b0 100644 --- a/lib/Machine.mli +++ b/lib/Machine.mli @@ -17,7 +17,6 @@ type _ Effect.t += | BRK : int Effect.t | DEI : ([ `Byte | `Short ] * int) -> int Effect.t | DEO : (int * int) -> unit Effect.t - | Trace : (int * Instr.t * int list) -> unit Effect.t val create : string -> machine -val dispatch : ?trace:bool -> machine -> int -> 'a +val dispatch : machine -> int -> 'a diff --git a/lib/Varvara/Console.ml b/lib/Varvara/Console.ml index 28bf22e..b782f97 100644 --- a/lib/Varvara/Console.ml +++ b/lib/Varvara/Console.ml @@ -4,9 +4,10 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct type nonrec state = state let state = { console_vector = 0 } - let can_handle port = port >= 0x10 && port <= 0x1f - let dei _ _ = None - let dei2 _ _ = None + let dei_ports = Uxn.Device.Int_set.empty + let deo_ports = Uxn.Device.Int_set.of_list [ 0x10; 0x18; 0x19 ] + let dei _ _ = assert false + let dei2 _ _ = assert false let deo _ port value = match port with @@ -17,5 +18,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct | 0x19 -> prerr_char (Char.chr value); Out_channel.flush stderr - | _ -> () + | _ -> assert false end diff --git a/lib/Varvara/Datetime.ml b/lib/Varvara/Datetime.ml new file mode 100644 index 0000000..3d43a40 --- /dev/null +++ b/lib/Varvara/Datetime.ml @@ -0,0 +1,34 @@ +module Make () : Uxn.Device.DEVICE with type state = unit = struct + type state = unit + + let state = () + + let dei_ports = + Uxn.Device.Int_set.of_list + [ 0xc0; 0xc2; 0xc3; 0xc4; 0xc5; 0xc6; 0xc7; 0xc8; 0xca ] + + let deo_ports = Uxn.Device.Int_set.empty + + let dei _ port = + let now = Unix.time () in + let tm = Unix.localtime now in + match port with + | 0xc2 -> tm.Unix.tm_mon + | 0xc3 -> tm.Unix.tm_mday + | 0xc4 -> tm.Unix.tm_hour + | 0xc5 -> tm.Unix.tm_min + | 0xc6 -> tm.Unix.tm_sec + | 0xc7 -> tm.Unix.tm_wday + | 0xca -> Bool.to_int tm.Unix.tm_isdst + | _ -> assert false + + let dei2 _ port = + let now = Unix.time () in + let tm = Unix.localtime now in + match port with + | 0xc0 -> tm.Unix.tm_year + 1900 + | 0xc8 -> tm.Unix.tm_yday + | _ -> assert false + + let deo _ _ _ = assert false +end diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml index 89b131c..8d23374 100644 --- a/lib/Varvara/File.ml +++ b/lib/Varvara/File.ml @@ -19,7 +19,18 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct type nonrec state = state let state = { filepath = None; state = Idle; length = 0 } - let can_handle port = port >= Addr.start && port <= Addr.start + 0x0f + let dei_ports = Uxn.Device.Int_set.empty + + let deo_ports = + Uxn.Device.Int_set.of_list + [ + Addr.start + 0x0a; + Addr.start + 0x04; + Addr.start + 0x06; + Addr.start + 0x08; + Addr.start + 0x0c; + Addr.start + 0x0e; + ] let read_cstring ram addr = let buf = Buffer.create 256 in @@ -194,8 +205,8 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct with Unix.Unix_error _ -> -1) let file_success dev port value = Bytes.set_uint16_be dev port value - let dei _ _ = None - let dei2 _ _ = None + let dei _ _ = assert false + let dei2 _ _ = assert false let deo mach port value = let open Uxn in @@ -211,5 +222,5 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct | 0x0e -> let append = Bytes.get_uint8 dev (Addr.start + 0x07) in file_write ram value state.length append |> with_success - | _ -> () + | _ -> failwith (Printf.sprintf "%02x" port) end diff --git a/lib/Varvara/System.ml b/lib/Varvara/System.ml index 047c3f5..8ae73a8 100644 --- a/lib/Varvara/System.ml +++ b/lib/Varvara/System.ml @@ -6,7 +6,8 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct type nonrec state = state let state = { banks = Array.init 15 (fun _ -> Bytes.create 65536) } - let can_handle port = port >= 0x00 && port <= 0x0f + let dei_ports = Uxn.Device.Int_set.of_list [ 0x04; 0x05 ] + let deo_ports = Uxn.Device.Int_set.of_list [ 0x02; 0x04; 0x05; 0x0e; 0x0f ] let print_stack ~name (Machine.Stack { data; sp }) = Printf.eprintf "%s " name; @@ -76,13 +77,13 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct match port with | 0x04 -> let (Machine.Stack { sp; _ }) = Machine.wst m in - Some sp + sp | 0x05 -> let (Machine.Stack { sp; _ }) = Machine.rst m in - Some sp - | _ -> None + sp + | _ -> assert false - let dei2 _ _ = None + let dei2 _ _ = assert false let deo mach port value = match port with @@ -100,5 +101,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct Out_channel.flush stderr end | 0x0f -> Bytes.set_uint8 (Machine.dev mach) 0x0f value - | _ -> () + | _ -> assert false end From 35b0a4f6dd1a8a6a247ca10dc4dea785e7e574c3 Mon Sep 17 00:00:00 2001 From: "Javier B. Torres" Date: Tue, 23 Dec 2025 18:02:22 -0300 Subject: [PATCH 10/10] revise File device according to new tests --- exe/uxnemu.ml | 4 +- lib/Machine.ml | 5 +- lib/Machine.mli | 3 +- lib/Varvara/File.ml | 20 ++++--- utils/varvara.file.tal | 131 +++++++++++++++++++++++++++-------------- 5 files changed, 106 insertions(+), 57 deletions(-) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 9939408..f16026b 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -28,14 +28,14 @@ let run m pc = let dev = Machine.dev m in try Machine.dispatch m pc with | effect Machine.BRK, _ -> () - | effect Machine.DEI (`Byte, port), k -> begin + | effect Machine.DEI port, k -> begin try let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE) in continue k (Device.dei m port) with Not_found -> continue k (Bytes.get_uint8 dev port) end - | effect Machine.DEI (`Short, port), k -> begin + | effect Machine.DEI2 port, k -> begin try let module Device = (val Hashtbl.find devices_dei port : Device.DEVICE) in diff --git a/lib/Machine.ml b/lib/Machine.ml index 4796104..b94d6f9 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -68,7 +68,8 @@ type machine = type _ Effect.t += | BRK : int Effect.t - | DEI : ([ `Byte | `Short ] * int) -> int Effect.t + | DEI : int -> int Effect.t + | DEI2 : int -> int Effect.t | DEO : (int * int) -> unit Effect.t let ram (Machine { data; _ }) = data @@ -226,7 +227,7 @@ let dispatch (Machine m) (pc : int) = | 0x16 (* DEI *) -> let port = popbyte mode stk in push mode stk - (perform (DEI ((if short then `Short else `Byte), port))) + (if short then perform (DEI2 port) else perform (DEI port)) | 0x17 (* DEO *) -> let port = popbyte mode stk in let value = pop mode stk in diff --git a/lib/Machine.mli b/lib/Machine.mli index 81494b0..453648c 100644 --- a/lib/Machine.mli +++ b/lib/Machine.mli @@ -15,7 +15,8 @@ val rst : machine -> stack type _ Effect.t += | BRK : int Effect.t - | DEI : ([ `Byte | `Short ] * int) -> int Effect.t + | DEI : int -> int Effect.t + | DEI2 : int -> int Effect.t | DEO : (int * int) -> unit Effect.t val create : string -> machine diff --git a/lib/Varvara/File.ml b/lib/Varvara/File.ml index 8d23374..fcbc78a 100644 --- a/lib/Varvara/File.ml +++ b/lib/Varvara/File.ml @@ -2,7 +2,7 @@ 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_read of Unix.dir_handle * string | Dir_write type state = { @@ -131,7 +131,8 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct match state.state with | File_read ic -> ( try - let bytes_read = input ic ram addr len in + let max_len = 0x10000 - addr in + let bytes_read = input ic ram addr (min max_len len) in bytes_read with | End_of_file -> 0 @@ -140,6 +141,7 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct try let contents = read_directory fp len in let bytes_to_copy = min len (String.length contents) in + let bytes_to_copy = min (0x10000 - addr) bytes_to_copy in Bytes.blit_string contents 0 ram addr bytes_to_copy; Unix.closedir dh; state.state <- Idle; @@ -173,9 +175,10 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct match state.state with | File_write oc -> ( try - output oc ram addr len; + let max_len = 0x10000 - addr in + output oc ram addr (min max_len len); flush oc; - len + min max_len len with Sys_error _ -> 0) | Dir_write -> if Sys.file_exists filepath && Sys.is_directory filepath then 1 @@ -190,19 +193,20 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct | Some filepath -> let stat_str = format_stat filepath len in let bytes_to_copy = min len (String.length stat_str) in + let bytes_to_copy = min (0x10000 - addr) bytes_to_copy in Bytes.blit_string stat_str 0 ram addr bytes_to_copy; bytes_to_copy let file_delete () = - if file_not_ready () then -1 + if file_not_ready () then 0 else match state.filepath with - | None -> -1 + | None -> 0 | Some filepath -> ( try Unix.unlink filepath; - 0 - with Unix.Unix_error _ -> -1) + 1 + with Unix.Unix_error _ -> 0) let file_success dev port value = Bytes.set_uint16_be dev port value let dei _ _ = assert false diff --git a/utils/varvara.file.tal b/utils/varvara.file.tal index 1035789..1067ef9 100644 --- a/utils/varvara.file.tal +++ b/utils/varvara.file.tal @@ -6,81 +6,124 @@ |100 @on-reset ( -> ) - file/ - file/ - #0004 .File/success DEI2 NEQ2 ?fail - ;file/a1 LDA2 ;file/a2 LDA2 NEQ2 ?fail - ;dict/load str/ - ;file/b1 LDA2 ;file/b2 LDA2 NEQ2 ?fail - ;dict/append str/ - ;file/stat-buf file/ - ;file/stat-hs LDA2 LIT2 "00 NEQ2 ?fail - ;file/stat-ls LDA2 LIT2 "04 NEQ2 ?fail - ;dict/stat str/ - file/ - ;file/null-buf file/ - ;file/null-buf LDA2 LIT2 "!! NEQ2 ?fail - ;dict/delete str/ #800f DEO - BRK - -@fail ( -> ) - ;dict/failed str/ - #010f DEO + ;dict/write file/test-write + ;dict/append file/test-append + ;dict/read file/test-read + ;dict/stat file/test-stat + ;dict/delete file/test-delete + ( | overflows ) + ;dict/write-of file/test-write-of + ;dict/read-of file/test-read-of + ;dict/stat-of file/test-stat-of + ( | cleanup ) + ;file/name .File/name DEO2 + #01 .File/delete DEO BRK ( -@|File ) +@|Tests ) -@file/ ( -- ) +@file/test-write ( -- pass ) ;&name .File/name DEO2 #0002 .File/length DEO2 ;&a1 .File/write DEO2 - ( | append ) + .File/success DEI2 #0002 EQU2 JMP2r + +@file/test-append ( -- pass ) ;&name .File/name DEO2 #0002 .File/length DEO2 #01 .File/append DEO ;&b1 .File/write DEO2 - JMP2r + .File/success DEI2 #0002 EQU2 JMP2r -@file/ ( -- ) +@file/test-read ( -- pass ) ;&name .File/name DEO2 - ( two more bytes than max length ) #0006 .File/length DEO2 - ;&load-buf .File/read DEO2 - JMP2r + ( 4+2 ) #0006 .File/length DEO2 + ;&read-buf .File/read DEO2 + ( success ) .File/success DEI2 #0004 EQU2 + ( a ) ;&a1 LDA2 ;&a2 LDA2 EQU2 AND + ( b ) ;&b1 LDA2 ;&b2 LDA2 EQU2 AND JMP2r -@file/ ( buf* -- ) +@file/test-stat ( -- pass ) ;&name .File/name DEO2 #0004 .File/length DEO2 - .File/stat DEO2 - JMP2r + ;&stat-buf .File/stat DEO2 + ( success ) .File/success DEI2 #0004 EQU2 + ( a ) ;&stat-hs LDA2 LIT2 "00 EQU2 AND + ( b ) ;&stat-ls LDA2 LIT2 "04 EQU2 AND + ( | try missing file ) + ;&unknown-name .File/name DEO2 + #0002 .File/length DEO2 + ;&stat-buf .File/stat DEO2 + ;&stat-buf LDA2 LIT2 "!! EQU2 AND JMP2r -@file/ ( -- ) +@file/test-delete ( -- pass ) ;&name .File/name DEO2 #01 .File/delete DEO - JMP2r + .File/success DEI2 #0001 EQU2 + ( | stat ) + ;&name .File/name DEO2 + #0002 .File/length DEO2 + ;&null-buf .File/stat DEO2 + ;&null-buf LDA2 LIT2 "!! EQU2 AND + ( | try failure ) + #01 .File/delete DEO + .File/success DEI2 #0000 EQU2 AND JMP2r - &name "test.txt $1 +@file/test-write-of ( -- pass ) + ;&name .File/name DEO2 + #0004 .File/length DEO2 + #fffe .File/write DEO2 + .File/success DEI2 #0002 EQU2 JMP2r + +@file/test-read-of ( -- pass ) + ;&name .File/name DEO2 + #0002 .File/length DEO2 + #ffff .File/read DEO2 + .File/success DEI2 #0001 EQU2 JMP2r + +@file/test-stat-of ( -- pass ) + ;&name .File/name DEO2 + #0004 .File/length DEO2 + #fffe .File/stat DEO2 + .File/success DEI2 #0002 EQU2 JMP2r ( -@|Utils ) +@|Helpers ) + +@ ( name* f -- ) + ?{ + str/ + #010f DEO + ;dict/fail !str/ } + str/ + ;dict/pass + ( >> ) @str/ ( str* -- ) LDAk DUP ?{ POP POP2 JMP2r } - #18 DEO + .Console/write DEO INC2 !/ ( -@|Data ) +@|Assets ) -@dict/failed "File: 20 "fail 0a $1 - &load "File/load: 20 "pass 0a $1 - &append "File/append: 20 "pass 0a $1 - &stat "File/stat: 20 "pass 0a $1 - &delete "File/delete: 20 "pass 0a $1 +@dict/write "File/write: 20 $1 + &append "File/append: 20 $1 + &read "File/read: 20 $1 + &stat "File/stat: 20 $1 + &delete "File/delete: 20 $1 + &write-of "File/write(overflow): 20 $1 + &read-of "File/read(overflow): 20 $1 + &stat-of "File/stat(overflow): 20 $1 + &fail "fail 0a $1 + &pass "pass 0a $1 -@file/data &a1 1234 &b1 5678 - ( load buf ) &load-buf &a2 $2 &b2 $2 +@file/a1 1234 &b1 5678 + ( read buf ) &read-buf &a2 $2 &b2 $2 ( stat buf ) &stat-buf &stat-hs $2 &stat-ls $2 ( null buf ) &null-buf $4 + &name "test.txt $1 + &unknown-name "abcdefghj $1