diff --git a/.gitignore b/.gitignore index a116061..b1d2cf0 100644 --- a/.gitignore +++ b/.gitignore @@ -3,4 +3,3 @@ /_opam /_build /utils/uxnmin -/.envrc diff --git a/README.md b/README.md index c486be7..156bc39 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,7 @@ 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. diff --git a/exe/dune b/exe/dune index 9d5c776..a95ce30 100644 --- a/exe/dune +++ b/exe/dune @@ -1,4 +1,4 @@ (executable (public_name uxnemu) (name uxnemu) - (libraries uxn varvara unix)) + (libraries uxn unix fmt)) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index f16026b..3e14f16 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -1,67 +1,135 @@ open Uxn open Effect.Deep -let devices_deo = Hashtbl.create 256 -let devices_dei = Hashtbl.create 256 +let debug = Option.is_some (Sys.getenv_opt "DBG") +let banks = Array.init 15 (fun _ -> Bytes.create 65536) -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 +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 -module System = Varvara.System.Make () -module Console = Varvara.Console.Make () -module Datetime = Varvara.Datetime.Make () +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 File_a = Varvara.File.Make (struct - let start = 0xa0 -end) +let print_stack ~name (Machine.Stack { data; sp }) = + Fmt.epr "%s: @[%a@]@." name + (Fmt.on_bytes (Fmt.octets ())) + (Bytes.sub data 0 sp) -module File_b = Varvara.File.Make (struct - let start = 0xb0 -end) - -let run m pc = +let rec run m pc = let dev = Machine.dev m in - try Machine.dispatch m pc with + 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 + 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; + 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 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.DEI2 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.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.DEO (port, value), k -> - begin try - let module Device = (val Hashtbl.find devices_deo port : Device.DEVICE) - in - Device.deo m port value - with Not_found -> () - end; + (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 := value + | 0x18 -> print_char (Char.chr value) + | 0x19 -> prerr_char (Char.chr value) + | _ -> ()); continue k () let main () = if Array.length Sys.argv < 2 then ( - Printf.eprintf "usage: uxnemu file.rom ...\n"; + Fmt.epr "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 @@ -70,38 +138,12 @@ let main () = Out_channel.set_binary_mode stdout true; let mach = Machine.create code in - 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); - + Bytes.set (Machine.dev mach) 0 '\x00'; run mach 0x100; - - 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.state.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 + if debug 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) + exit (Bytes.get_uint8 (Machine.dev mach) 0x0f land 0x7f) let _ = main () diff --git a/lib/Device.ml b/lib/Device.ml deleted file mode 100644 index f538681..0000000 --- a/lib/Device.ml +++ /dev/null @@ -1,12 +0,0 @@ -module Int_set = Set.Make (Int) - -module type DEVICE = sig - type state - - val state : state - 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 diff --git a/lib/Machine.ml b/lib/Machine.ml index b94d6f9..1ca17cf 100644 --- a/lib/Machine.ml +++ b/lib/Machine.ml @@ -5,10 +5,7 @@ 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 () = - let data = Bytes.create 256 in - Bytes.unsafe_fill data 0 256 '\x00'; - Stack { data; sp = 0 } +let stack_create () = Stack { data = Bytes.create 256; sp = 0 } let peek (Mode { short; keep; temp }) (Stack { data; sp }) : int = let amt = if short then 2 else 1 in @@ -39,6 +36,13 @@ 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 @@ -68,9 +72,12 @@ type machine = type _ Effect.t += | BRK : int Effect.t - | DEI : int -> int Effect.t - | DEI2 : int -> 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 + +type machine_state = Break | Next of int let ram (Machine { data; _ }) = data let dev (Machine { dev; _ }) = dev @@ -85,48 +92,58 @@ let create code = Bytes.blit_string code 0 data 0x100 (String.length code); Machine { data; dev; stack = stack_create (); callstack = stack_create () } -let dispatch (Machine m) (pc : int) = +let dispatch ?(trace = false) ?(breakpoints = []) (Machine m) (pc : int) = let pc = ref pc in while true do - let op = Bytes.get_uint8 m.data (!pc land 0xffff) in - pc := (!pc + 1) land 0xffff; + pc := !pc 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 + 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; 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 ]; 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 ]; 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 ]; push2 m.callstack (!pc + 2); pc := !pc + addr + 2 | 0x80 (* LIT *) -> let lit = Bytes.get_uint8 m.data !pc in + trace [ lit ]; push1 m.stack lit; pc := !pc + 1 | 0xa0 (* LIT2 *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in + trace [ lit ]; push2 m.stack lit; pc := !pc + 2 | 0xc0 (* LITr *) -> let lit = Bytes.get_uint8 m.data !pc in + trace [ lit ]; push1 m.callstack lit; pc := !pc + 1 | 0xe0 (* LIT2r *) -> let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in + trace [ 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 = @@ -135,136 +152,166 @@ let dispatch (Machine m) (pc : int) = match[@warning "-8"] opcode with | 0x01 (* INC *) -> let r = pop mode stk in + trace [ r ]; push mode stk (r + 1) - | 0x02 (* POP *) -> ignore (pop mode stk) + | 0x02 (* POP *) -> trace [ pop mode stk ] | 0x03 (* NIP *) -> let b = pop mode stk in - ignore (pop mode stk); + let a = pop mode stk in + trace [ a; b ]; push mode stk b | 0x04 (* SWP *) -> let b = pop mode stk in let a = pop mode stk in + trace [ 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 ]; push mode stk b; push mode stk c; push mode stk a | 0x06 (* DUP *) -> let a = pop mode stk in + trace [ 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 ]; 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 ]; 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 ]; 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 ]; 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 ]; pushbyte mode stk (if a < b then 1 else 0) | 0x0c (* JMP *) -> let addr = pop mode stk in + trace [ 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 ]; 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 ]; if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr | 0x0f (* STH *) -> let a = pop mode stk in + trace [ a ]; push mode stk' a | 0x10 (* LDZ *) -> let addr = popbyte mode stk in + trace [ 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 ]; 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 ]; 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 ]; 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 ]; 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 ]; 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 ]; push mode stk - (if short then perform (DEI2 port) else perform (DEI port)) + (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 ]; 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 ]; push mode stk (a + b) | 0x19 (* SUB *) -> let b = pop mode stk in let a = pop mode stk in + trace [ a; b ]; push mode stk (a - b) | 0x1a (* MUL *) -> let b = pop mode stk in let a = pop mode stk in + trace [ a; b ]; push mode stk (a * b) | 0x1b (* DIV *) -> let b = pop mode stk in let a = pop mode stk in + trace [ 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 ]; push mode stk (a land b) | 0x1d (* ORA *) -> let b = pop mode stk in let a = pop mode stk in + trace [ 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 ]; push mode stk (a lxor b) | 0x1f (* SFT *) -> let sft = popbyte mode stk in let value = pop mode stk in + trace [ 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 453648c..1d00709 100644 --- a/lib/Machine.mli +++ b/lib/Machine.mli @@ -5,6 +5,10 @@ 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 @@ -13,11 +17,14 @@ 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 : int -> int Effect.t - | DEI2 : int -> 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 : machine -> int -> 'a +val dispatch : ?trace:bool -> ?breakpoints:int list -> machine -> int -> 'a diff --git a/lib/Varvara/Console.ml b/lib/Varvara/Console.ml deleted file mode 100644 index b782f97..0000000 --- a/lib/Varvara/Console.ml +++ /dev/null @@ -1,22 +0,0 @@ -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 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 - | 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 - | _ -> assert false -end diff --git a/lib/Varvara/Datetime.ml b/lib/Varvara/Datetime.ml deleted file mode 100644 index 3d43a40..0000000 --- a/lib/Varvara/Datetime.ml +++ /dev/null @@ -1,34 +0,0 @@ -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 deleted file mode 100644 index fcbc78a..0000000 --- a/lib/Varvara/File.ml +++ /dev/null @@ -1,230 +0,0 @@ -type file_state = - | Idle - | File_read of in_channel - | File_write of out_channel - | Dir_read of Unix.dir_handle * string - | Dir_write - -type state = { - mutable filepath : string option; - mutable state : file_state; - mutable length : int; -} - -module type ADDR = sig - val start : int -end - -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 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 - 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 addr = - file_reset state; - state.filepath <- Some (read_cstring ram addr); - 0 - - let file_not_ready () = state.filepath |> Option.is_none - - 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 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 max_len = 0x10000 - addr in - let bytes_read = input ic ram addr (min max_len 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 - 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; - bytes_to_copy - with Unix.Unix_error _ -> 0) - | _ -> 0) - - 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 - let max_len = 0x10000 - addr in - output oc ram addr (min max_len len); - flush oc; - min max_len 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 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 - 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 0 - else - match state.filepath with - | None -> 0 - | Some filepath -> ( - try - Unix.unlink filepath; - 1 - with Unix.Unix_error _ -> 0) - - let file_success dev port value = Bytes.set_uint16_be dev port value - let dei _ _ = assert false - let dei2 _ _ = assert false - - 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 + 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 + 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 deleted file mode 100644 index 8ae73a8..0000000 --- a/lib/Varvara/System.ml +++ /dev/null @@ -1,105 +0,0 @@ -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 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; - 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 - 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 - sp - | 0x05 -> - let (Machine.Stack { sp; _ }) = Machine.rst m in - sp - | _ -> assert false - - let dei2 _ _ = assert false - - 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 - | _ -> assert false -end diff --git a/lib/Varvara/dune b/lib/Varvara/dune deleted file mode 100644 index 600c2de..0000000 --- a/lib/Varvara/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name varvara) - (libraries uxn unix)) diff --git a/lib/dune b/lib/dune index 03870e8..ba1ed70 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,5 @@ +(include_subdirs qualified) + (library (name uxn) (libraries unix)) diff --git a/shell.nix b/shell.nix index 6b2bc7e..786f1c7 100644 --- a/shell.nix +++ b/shell.nix @@ -1,13 +1,7 @@ -{ - pkgs ? import { }, -}: - +{ pkgs ? import {} }: pkgs.mkShell { buildInputs = with pkgs; [ - clang-tools - hyperfine xxd - uxn ocamlPackages.ocaml ocamlPackages.dune_3 ocamlPackages.findlib @@ -15,5 +9,6 @@ pkgs.mkShell { ocamlPackages.ocamlformat ocamlPackages.merlin ocamlPackages.ocaml-lsp + ocamlPackages.fmt ]; } diff --git a/utils/Makefile b/utils/Makefile index 6882f8e..fbe5a68 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -1,9 +1,9 @@ .PHONY: all clean .SUFFIXES: .tal .rom -all: uxnmin drifloon.rom opctest.rom varvara.file.rom +all: uxnmin drifloon.rom opctest.rom clean: - rm -f uxnmin *.rom + rm -f uxnmin drifloon.rom opctest.rom uxnmin: uxnmin.c drifloon.rom: uxnmin diff --git a/utils/drifblim.tal b/utils/drifblim.tal deleted file mode 100644 index bc48d63..0000000 --- a/utils/drifblim.tal +++ /dev/null @@ -1,811 +0,0 @@ -( 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 - diff --git a/utils/varvara.file.tal b/utils/varvara.file.tal deleted file mode 100644 index 1067ef9..0000000 --- a/utils/varvara.file.tal +++ /dev/null @@ -1,129 +0,0 @@ -( 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 ( -> ) - #800f 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 - -( -@|Tests ) - -@file/test-write ( -- pass ) - ;&name .File/name DEO2 - #0002 .File/length DEO2 - ;&a1 .File/write DEO2 - .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 - .File/success DEI2 #0002 EQU2 JMP2r - -@file/test-read ( -- pass ) - ;&name .File/name DEO2 - ( 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/test-stat ( -- pass ) - ;&name .File/name DEO2 - #0004 .File/length DEO2 - ;&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/test-delete ( -- pass ) - ;&name .File/name DEO2 - #01 .File/delete DEO - .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 - -@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 - -( -@|Helpers ) - -@ ( name* f -- ) - ?{ - str/ - #010f DEO - ;dict/fail !str/ } - str/ - ;dict/pass - ( >> ) - -@str/ ( str* -- ) - LDAk DUP ?{ POP POP2 JMP2r } - .Console/write DEO - INC2 !/ - -( -@|Assets ) - -@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/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 -