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. diff --git a/exe/dune b/exe/dune index a95ce30..9d5c776 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)) diff --git a/exe/uxnemu.ml b/exe/uxnemu.ml index 3e14f16..f16026b 100644 --- a/exe/uxnemu.ml +++ b/exe/uxnemu.ml @@ -1,135 +1,67 @@ open Uxn open Effect.Deep -let debug = Option.is_some (Sys.getenv_opt "DBG") -let banks = Array.init 15 (fun _ -> Bytes.create 65536) +let devices_deo = Hashtbl.create 256 +let devices_dei = Hashtbl.create 256 -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 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 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 Datetime = Varvara.Datetime.Make () -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_a = Varvara.File.Make (struct + let start = 0xa0 +end) -let rec run m pc = +module File_b = Varvara.File.Make (struct + let start = 0xb0 +end) + +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 - 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) + try Machine.dispatch m pc with | 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 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.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 := value - | 0x18 -> print_char (Char.chr value) - | 0x19 -> prerr_char (Char.chr 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 () = if Array.length Sys.argv < 2 then ( - Fmt.epr "usage: uxnemu file.rom ...\n"; + 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 @@ -138,12 +70,38 @@ 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 debug then begin - print_stack ~name:"wst" (Machine.wst mach); - print_stack ~name:"rst" (Machine.rst mach) + + 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 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/Device.ml b/lib/Device.ml new file mode 100644 index 0000000..f538681 --- /dev/null +++ b/lib/Device.ml @@ -0,0 +1,12 @@ +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 1ca17cf..b94d6f9 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 @@ -72,12 +68,9 @@ 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 - | 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 @@ -92,58 +85,48 @@ 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 (Machine m) (pc : int) = let pc = ref pc 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 - if List.mem !pc breakpoints then perform (Breakpoint !pc); - + 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 ]; 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 = @@ -152,166 +135,136 @@ let dispatch ?(trace = false) ?(breakpoints = []) (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 *) -> trace [ pop mode stk ] + | 0x02 (* POP *) -> ignore (pop mode stk) | 0x03 (* NIP *) -> let b = pop mode stk in - let a = pop mode stk in - trace [ 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 [ 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 - (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 - 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 1d00709..453648c 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 + | DEI : int -> int Effect.t + | DEI2 : 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 -> ?breakpoints:int list -> machine -> int -> 'a +val dispatch : machine -> int -> 'a diff --git a/lib/Varvara/Console.ml b/lib/Varvara/Console.ml new file mode 100644 index 0000000..b782f97 --- /dev/null +++ b/lib/Varvara/Console.ml @@ -0,0 +1,22 @@ +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 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 new file mode 100644 index 0000000..fcbc78a --- /dev/null +++ b/lib/Varvara/File.ml @@ -0,0 +1,230 @@ +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 new file mode 100644 index 0000000..8ae73a8 --- /dev/null +++ b/lib/Varvara/System.ml @@ -0,0 +1,105 @@ +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 new file mode 100644 index 0000000..600c2de --- /dev/null +++ b/lib/Varvara/dune @@ -0,0 +1,3 @@ +(library + (name varvara) + (libraries uxn 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 786f1c7..6b2bc7e 100644 --- a/shell.nix +++ b/shell.nix @@ -1,7 +1,13 @@ -{ pkgs ? import {} }: +{ + pkgs ? import { }, +}: + pkgs.mkShell { buildInputs = with pkgs; [ + clang-tools + hyperfine xxd + uxn ocamlPackages.ocaml ocamlPackages.dune_3 ocamlPackages.findlib @@ -9,6 +15,5 @@ pkgs.mkShell { ocamlPackages.ocamlformat ocamlPackages.merlin ocamlPackages.ocaml-lsp - ocamlPackages.fmt ]; } diff --git a/utils/Makefile b/utils/Makefile index fbe5a68..6882f8e 100644 --- a/utils/Makefile +++ b/utils/Makefile @@ -1,9 +1,9 @@ .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 + rm -f uxnmin *.rom uxnmin: uxnmin.c drifloon.rom: uxnmin 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 + diff --git a/utils/varvara.file.tal b/utils/varvara.file.tal new file mode 100644 index 0000000..1067ef9 --- /dev/null +++ b/utils/varvara.file.tal @@ -0,0 +1,129 @@ +( 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 +