Compare commits
No commits in common. "35b0a4f6dd1a8a6a247ca10dc4dea785e7e574c3" and "373a739c8f24b5c3a5ef055a3e9f8977d03bcea0" have entirely different histories.
35b0a4f6dd
...
373a739c8f
17 changed files with 206 additions and 1455 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -3,4 +3,3 @@
|
|||
/_opam
|
||||
/_build
|
||||
/utils/uxnmin
|
||||
/.envrc
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
2
exe/dune
2
exe/dune
|
|
@ -1,4 +1,4 @@
|
|||
(executable
|
||||
(public_name uxnemu)
|
||||
(name uxnemu)
|
||||
(libraries uxn varvara unix))
|
||||
(libraries uxn unix fmt))
|
||||
|
|
|
|||
200
exe/uxnemu.ml
200
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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
(library
|
||||
(name varvara)
|
||||
(libraries uxn unix))
|
||||
2
lib/dune
2
lib/dune
|
|
@ -1,3 +1,5 @@
|
|||
(include_subdirs qualified)
|
||||
|
||||
(library
|
||||
(name uxn)
|
||||
(libraries unix))
|
||||
|
|
|
|||
|
|
@ -1,13 +1,7 @@
|
|||
{
|
||||
pkgs ? import <nixpkgs> { },
|
||||
}:
|
||||
|
||||
{ pkgs ? import <nixpkgs> {} }:
|
||||
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
|
||||
];
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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/<set>
|
||||
;src/on-console
|
||||
( >> )
|
||||
|
||||
@bind ( vector* -> )
|
||||
.Console/vector DEO2
|
||||
[ LIT2 03 -Console/type ] DEI AND ?{
|
||||
;dict/usage err/<print>
|
||||
[ 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/<generic> }
|
||||
NIP STZ
|
||||
BRK }
|
||||
( | src -> dst )
|
||||
;dst/on-console !bind
|
||||
|
||||
@dst/on-console ( -> )
|
||||
[ LIT2 02 -Console/type ] DEI LTH ?{ .Console/read DEI /<push>
|
||||
BRK }
|
||||
( | assemble )
|
||||
;src/buf assembly/<handle-file>
|
||||
assembly/<resolve>
|
||||
BRK
|
||||
|
||||
@dst/<push> ( c -- )
|
||||
[ LIT2 -&cap &ptr -&buf ] INCk ,&ptr STR
|
||||
NEQk ?{ ;dict/exceeded ;&buf ;dict/Path err/<generic> }
|
||||
NIP STZ
|
||||
JMP2r
|
||||
|
||||
@dst/<push-str> ( str* -- )
|
||||
LDAk DUP ?{ POP POP2 JMP2r }
|
||||
/<push>
|
||||
INC2 !/<push-str>
|
||||
|
||||
@err/<emit> ( c -- )
|
||||
#19 DEO
|
||||
JMP2r
|
||||
|
||||
@runes/concat INC2
|
||||
( >> )
|
||||
|
||||
@assembly/<handle-file> ( f* -- )
|
||||
.File/name DEO2
|
||||
#0001 .File/length DEO2
|
||||
token/<new>
|
||||
#0000
|
||||
&>s
|
||||
.System/state DEI ?&end
|
||||
;&c .File/read DEO2
|
||||
.File/success-lb DEI ?{
|
||||
ORAk ?{ ;dict/invalid ;src/buf ;dict/File err/<generic> }
|
||||
&end ( i* -- )
|
||||
POP2 JMP2r }
|
||||
INC2 [ LIT &c $1 ] token/<push-byte> !&>s
|
||||
|
||||
@rom/<put> ( 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/<emit> ( -- )
|
||||
;dict/assembled err/<print>
|
||||
#20 err/<emit>
|
||||
;dst/buf err/<print>
|
||||
;dict/in err/<print>
|
||||
;head/length LDA2 DUP2 #0100 SUB2 err/<pdec>
|
||||
;dict/bytes err/<print>
|
||||
( | 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/<push-str>
|
||||
;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/<resolve> ( -- )
|
||||
( cap ) #0a token/<push-byte>
|
||||
,&mode LDR2 ;comment/assemble NEQ2 ?{
|
||||
( ! ) ;dict/open ;dict/trail ;dict/Comment err/<generic> }
|
||||
,&mode LDR2 ;macros/assemble NEQ2 ?{
|
||||
( ! ) ;dict/open ;dict/trail ;dict/Macro err/<generic> }
|
||||
.System/state DEI ?{
|
||||
refs/<resolve-all>
|
||||
.System/state DEI ?{
|
||||
[ LIT2 80 -System/state ] DEO !syms/<emit> } }
|
||||
JMP2r
|
||||
|
||||
@assembly/apply ( t* -- )
|
||||
LDZk ?{ POP2 JMP2r }
|
||||
[ LIT2 &mode =standard/assemble ] JMP2
|
||||
|
||||
(
|
||||
@|Standard )
|
||||
|
||||
@standard/<latch> ( -- )
|
||||
;&assemble ;assembly/mode STA2
|
||||
JMP2r
|
||||
|
||||
@standard/assemble ( t* -- )
|
||||
( hex ) str/is-hex ?rom/<write-rawhex>
|
||||
( opc ) opcodes/is-opcode ?rom/<write-opcode>
|
||||
LDZk runes/find INC2k ORA ?{
|
||||
POP2
|
||||
( mac ) DUP2 macros/find-name INC2k ORA ?macros/<write>
|
||||
POP2
|
||||
( imm ) !runes/litjsi }
|
||||
INC2 LDA2 JMP2
|
||||
|
||||
(
|
||||
@|Comment )
|
||||
|
||||
@comment/<latch> ( 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/<latch> }
|
||||
JMP2r
|
||||
|
||||
(
|
||||
@|Macros )
|
||||
|
||||
@macros/<latch> ( t* -- )
|
||||
name/<validate>
|
||||
/<push-word>
|
||||
#00 /<push-byte>
|
||||
;&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 /<push-byte> !standard/<latch> }
|
||||
/<push-word>
|
||||
#20 !/<push-byte>
|
||||
|
||||
@macros/<push-word> ( t* -- )
|
||||
;/<push-byte> !hof/<each>
|
||||
|
||||
@macros/<push-byte> ( byte -- )
|
||||
[ LIT2 &ptr =&mem ] INC2k
|
||||
( | check overflow )
|
||||
DUP2 ;&memend LTH2 ?{
|
||||
( ! ) ;dict/exceeded ;dict/Macros err/<token> }
|
||||
,&ptr STR2
|
||||
STA
|
||||
JMP2r
|
||||
|
||||
@macros/find-name ( name* -- <addr>* )
|
||||
STH2
|
||||
,&ptr LDR2 ;&mem
|
||||
&>lf
|
||||
DUP2 STH2kr str/cmp ?{
|
||||
str/cap str/cap GTH2k ?&>lf
|
||||
POP2 #ffff }
|
||||
NIP2 POP2r JMP2r
|
||||
|
||||
@macros/<write> ( t* macro* -- )
|
||||
NIP2 token/<new>
|
||||
str/cap ;token/<push-byte> !hof/<each>
|
||||
|
||||
(
|
||||
@|Token )
|
||||
|
||||
@token/<new> ( -- )
|
||||
[ LIT2 -&buf _&ptr ] STR
|
||||
[ LIT2 00 -&buf ] STZ
|
||||
JMP2r
|
||||
|
||||
@token/<push-byte> ( c -- )
|
||||
DUP #20 GTH ?{
|
||||
;&buf assembly/apply #0a NEQ ?{
|
||||
[ LIT2 &line 0001 ] INC2 ,&line STR2 }
|
||||
!/<new> }
|
||||
[ LIT2 00 &ptr -&buf ] INCk
|
||||
( | check overflow )
|
||||
DUP .&cap LTH ?{
|
||||
( ! ) ;dict/exceeded ;dict/Name err/<token> }
|
||||
,&ptr STR
|
||||
STZ2
|
||||
JMP2r
|
||||
|
||||
(
|
||||
@|Scope )
|
||||
|
||||
@scope/<push-byte> ( c -- )
|
||||
[ LIT2 00 &ptr -&buf ] INCk
|
||||
( | check overflow )
|
||||
DUP .&cap LTH ?{
|
||||
( ! ) ;dict/exceeded ;dict/Symbol err/<token> }
|
||||
,&ptr STR
|
||||
STZ2
|
||||
JMP2r
|
||||
|
||||
@scope/<set> ( name* -- )
|
||||
[ LIT2 -&buf _&ptr ] STR
|
||||
&>w
|
||||
LDAk [ LIT "/ ] EQU ?{
|
||||
LDAk /<push-byte>
|
||||
INC2 LDAk ?&>w }
|
||||
POP2 ,&ptr LDR ,&anchor STR
|
||||
JMP2r
|
||||
|
||||
@scope/make-name ( name* -- scope/label* )
|
||||
INC2 [ LIT2 &anchor $1 _&ptr ] STR
|
||||
[ LIT "/ ] /<push-byte>
|
||||
;&buf SWP2 ;/<push-byte> !hof/<each>
|
||||
|
||||
(
|
||||
@|Runes )
|
||||
|
||||
@runes/find ( char -- <addr>* )
|
||||
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/<latch>
|
||||
|
||||
¯os ( t* -- )
|
||||
/req-name !macros/<latch>
|
||||
|
||||
&padabs ( t* -- )
|
||||
/req-name syms/find-addr !head/<set>
|
||||
|
||||
&padrel ( t* -- )
|
||||
/req-name syms/find-addr !head/<set-rel>
|
||||
|
||||
&toplab ( t* -- )
|
||||
/req-name DUP2 scope/<set> !syms/<new>
|
||||
|
||||
&sublab ( t* -- )
|
||||
scope/make-name !syms/<new>
|
||||
|
||||
&litrel ( t* -- )
|
||||
#80 rom/<write-byte> &rawrel /req-name refs/get-rel !rom/<write-byte>
|
||||
|
||||
&litzep ( t* -- )
|
||||
#80 rom/<write-byte> &rawzep /req-name refs/get-abs !rom/<write-byte>
|
||||
|
||||
&litabs ( t* -- )
|
||||
#a0 rom/<write-byte> &rawabs /req-name refs/get-abs2 !rom/<write-short>
|
||||
|
||||
&litjci ( t* -- )
|
||||
/req-name #20 !rom/<write-call>
|
||||
|
||||
&litjmi ( t* -- )
|
||||
/req-name #40 !rom/<write-call>
|
||||
|
||||
&litjsi ( t* -- )
|
||||
#60 !rom/<write-call>
|
||||
|
||||
&lithex ( t* -- )
|
||||
/req-name !rom/<write-lithex>
|
||||
|
||||
&rawstr ( t* -- )
|
||||
/req-name !rom/<write-str>
|
||||
|
||||
@runes/req-name ( str* -- str1* )
|
||||
INC2 LDAk #20 GTH ?{ ;dict/invalid ;dict/Name !err/<token> }
|
||||
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/<new>
|
||||
,&ptr STR2
|
||||
JMP2r
|
||||
&sym cebb
|
||||
&id1 "..
|
||||
&id2 ".. 00
|
||||
|
||||
(
|
||||
@|Name )
|
||||
|
||||
@name/<validate> ( 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/<token>
|
||||
|
||||
&dup ( -- )
|
||||
;dict/duplicate ;dict/Name !err/<token>
|
||||
|
||||
@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/<new> ( name* -- )
|
||||
DUP2 /find-name INC2k ORA ?{
|
||||
POP2 ;&ptr LDA2 refs/<record-scope>
|
||||
.SymType/declared head/get !/<push-sym> }
|
||||
( | name* sym* -- )
|
||||
NIP2 DUP2 refs/<record-scope>
|
||||
/is-declared ?{ head/get OVR2 STA2 !/<declare> }
|
||||
POP2
|
||||
( ! ) ;dict/duplicate ;dict/Symbol !err/<token>
|
||||
|
||||
@syms/<push-sym> ( name* type addr* -- )
|
||||
( hb ) SWP /<push-byte>
|
||||
( lb ) /<push-byte>
|
||||
( type ) /<push-byte>
|
||||
name/<validate>
|
||||
;/<push-byte> hof/<each>
|
||||
#00
|
||||
( >> )
|
||||
|
||||
@syms/<push-byte> ( byte -- )
|
||||
[ LIT2 &ptr =&mem ] INC2k
|
||||
( | check overflow )
|
||||
DUP2 ;refs/ptr LDA2 LTH2 ?{
|
||||
( ! ) ;dict/exceeded ;dict/Symbols err/<token> }
|
||||
,&ptr STR2
|
||||
STA
|
||||
JMP2r
|
||||
|
||||
@syms/find-name ( name* -- <sym>* )
|
||||
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* -- <addr>* )
|
||||
DUP2 /find-name INC2k ORA ?{
|
||||
( null* .. next* ) POP2 ,&ptr LDR2
|
||||
( alloc ) SWP2 .SymType/used #ffff !/<push-sym> }
|
||||
NIP2 JMP2r
|
||||
|
||||
@syms/find-addr ( name* -- <addr>* )
|
||||
str/is-hex ?str/hex
|
||||
name/unpack /find-name /is-defined ?{
|
||||
( ! ) ;dict/invalid ;dict/Symbol err/<token> }
|
||||
/use LDA2 JMP2r
|
||||
|
||||
@syms/<emit> ( -- )
|
||||
;&ptr LDA2 ;&mem
|
||||
&>ls
|
||||
EQU2k ?{
|
||||
/is-used ?{
|
||||
LDA2k #0100 EQU2 ?{
|
||||
DUP2 #0003 ADD2 LDAk [ LIT "A ] SUB #1a LTH ?{
|
||||
;dict/unused err/<print>
|
||||
DUP2 err/<print>
|
||||
#0a err/<emit> }
|
||||
POP2 } }
|
||||
#0003 ADD2 str/cap !&>ls }
|
||||
POP2 POP2 !rom/<emit>
|
||||
|
||||
@syms/byte-distance ( addr* -- addr* )
|
||||
DUP2 #0080 ADD2 POP ?{ JMP2r }
|
||||
( ! ) ;dict/too-far ;dict/Symbol !err/<token>
|
||||
|
||||
@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/<declare> ( 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* ) /<push-short>
|
||||
( symbol* ) /<push-short>
|
||||
( type-fn* ) [ LIT2 &type $2 ] /<push-short>
|
||||
( scope* ) [ LIT2 &scope $2 ] /<push-short>
|
||||
( line* ) ;token/line LDA2 /<push-short>
|
||||
,&ptr LDR2 #000a SUB2 ,&ptr STR2 }
|
||||
( | mark as used )
|
||||
syms/use LDA2 JMP2r
|
||||
|
||||
@refs/<push-short> ( value* -- )
|
||||
SWP /<push-byte>
|
||||
( >> )
|
||||
|
||||
@refs/<push-byte> ( byte -- )
|
||||
[ LIT2 &ptr =&memend ] INC2k
|
||||
( | check overflow )
|
||||
DUP2 ;syms/ptr LDA2 GTH2 ?{
|
||||
( ! ) ;dict/exceeded ;dict/References err/<token> }
|
||||
,&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/<resolve-all> ( -- )
|
||||
,&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/<set>
|
||||
( ref* sym* ) INC2k INC2 LDA2
|
||||
( ref* sym/addr* ) LDA2
|
||||
( ref* sym/addr* ) INC2k ORA ?{
|
||||
( ! ) ;dict/invalid !err/<resolution> }
|
||||
( ref* sym/addr* ) JMP2r
|
||||
|
||||
@refs/handle-abs ( ref* -- )
|
||||
/resolve-sym NIP2 NIP !rom/<write-byte>
|
||||
|
||||
@refs/handle-abs2 ( ref* -- )
|
||||
/resolve-sym NIP2 !rom/<write-short>
|
||||
|
||||
@refs/handle-rel ( ref* -- )
|
||||
/resolve-sym SWP2 LDA2 /get-distance /byte-distance NIP !rom/<write-byte>
|
||||
|
||||
@refs/handle-rel2 ( ref* -- )
|
||||
/resolve-sym SWP2 LDA2 /get-distance !rom/<write-short>
|
||||
|
||||
@refs/byte-distance ( addr* -- addr* )
|
||||
DUP2 #0080 ADD2 POP ?{ JMP2r }
|
||||
( ! ) ;dict/too-far !err/<resolution>
|
||||
|
||||
@refs/<record-scope> ( sym* -- )
|
||||
DUP2 #0003 ADD2 LDA2 #cebb NEQ2 ?{ POP2 JMP2r }
|
||||
;refs/scope STA2
|
||||
JMP2r
|
||||
|
||||
(
|
||||
@|Rom )
|
||||
|
||||
@rom/<write-str> ( str* -- )
|
||||
;/<write-byte> !hof/<each>
|
||||
|
||||
@rom/<write-opcode> ( str* -- )
|
||||
opcodes/parse !/<write-byte>
|
||||
|
||||
@rom/<write-lithex> ( str* -- )
|
||||
str/len #02 NEQ #50 SFT #80 ORA /<write-byte>
|
||||
( >> )
|
||||
|
||||
@rom/<write-rawhex> ( str* -- )
|
||||
str/is-hex #00 EQU ?{
|
||||
str/len DUP #02 NEQ ?{ POP str/hex NIP !/<write-byte> }
|
||||
#04 NEQ ?{ str/hex !/<write-short> } }
|
||||
POP2 ;dict/invalid ;dict/Number !err/<token>
|
||||
|
||||
@rom/<write-call> ( str* opc -- )
|
||||
/<write-byte>
|
||||
refs/get-rel2
|
||||
( >> )
|
||||
|
||||
@rom/<write-short> ( short* -- )
|
||||
SWP /<write-byte>
|
||||
( >> )
|
||||
|
||||
@rom/<write-byte> ( byte -- )
|
||||
head/get-inc
|
||||
( | test zero-page )
|
||||
OVR ?{
|
||||
POP2 POP
|
||||
( ! ) ;dict/zero-page ;dict/Writing !err/<token> }
|
||||
!rom/<put>
|
||||
|
||||
@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/<set-rel> ( addr* -- )
|
||||
/get ADD2
|
||||
( >> )
|
||||
|
||||
@head/<set> ( addr* -- )
|
||||
,&addr STR2
|
||||
JMP2r
|
||||
|
||||
(
|
||||
@|Stdlib )
|
||||
|
||||
@hof/<each> ( 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* <val> )
|
||||
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/<token> ( adj* topic* -- )
|
||||
.System/state DEI ?{
|
||||
[ LIT2 01 -System/state ] DEO
|
||||
/<print>
|
||||
#20 /<emit>
|
||||
/<print>
|
||||
;dict/spacer /<print>
|
||||
;token/buf /<print>
|
||||
;token/line LDA2 ;scope/buf !/<print-location> }
|
||||
POP2 POP2 JMP2r
|
||||
|
||||
@err/<resolution> ( adj* -- )
|
||||
.System/state DEI ?{
|
||||
[ LIT2 01 -System/state ] DEO
|
||||
;dict/Reference /<print>
|
||||
#20 /<emit>
|
||||
/<print>
|
||||
;dict/spacer /<print>
|
||||
[ LIT2 &ref $2 ] INC2k INC2 LDA2 #0003 ADD2 /<print>
|
||||
DUP2 #0008 ADD2 LDA2 SWP2 #0006 ADD2 LDA2 #0003 ADD2 !/<print-location> }
|
||||
POP2 JMP2r
|
||||
|
||||
@err/<print-location> ( line* scope* -- )
|
||||
;dict/in /<print>
|
||||
/<print>
|
||||
LIT ": /<emit>
|
||||
/<pdec>
|
||||
#0a /<emit>
|
||||
JMP2r
|
||||
|
||||
@err/<generic> ( adj* keyword* topic* -- )
|
||||
.System/state DEI ?{
|
||||
[ LIT2 01 -System/state ] DEO
|
||||
/<print>
|
||||
#20 /<emit>
|
||||
SWP2 /<print>
|
||||
;dict/spacer /<print>
|
||||
/<print>
|
||||
#0a /<emit>
|
||||
JMP2r }
|
||||
POP2 POP2 POP2 JMP2r
|
||||
|
||||
@err/<print> ( str* -- )
|
||||
;/<emit> !hof/<each>
|
||||
|
||||
@err/<pdec> ( short* -- )
|
||||
[ LIT2r ff00 ]
|
||||
&>read
|
||||
#000a DIV2k STH2k MUL2 SUB2 STH2r INCr ORAk ?&>read
|
||||
POP2
|
||||
&>write
|
||||
NIP #30 ADD /<emit>
|
||||
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
|
||||
|
||||
|
|
@ -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 <test>
|
||||
;dict/append file/test-append <test>
|
||||
;dict/read file/test-read <test>
|
||||
;dict/stat file/test-stat <test>
|
||||
;dict/delete file/test-delete <test>
|
||||
( | overflows )
|
||||
;dict/write-of file/test-write-of <test>
|
||||
;dict/read-of file/test-read-of <test>
|
||||
;dict/stat-of file/test-stat-of <test>
|
||||
( | 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 )
|
||||
|
||||
@<test> ( name* f -- )
|
||||
?{
|
||||
str/<print>
|
||||
#010f DEO
|
||||
;dict/fail !str/<print> }
|
||||
str/<print>
|
||||
;dict/pass
|
||||
( >> )
|
||||
|
||||
@str/<print> ( str* -- )
|
||||
LDAk DUP ?{ POP POP2 JMP2r }
|
||||
.Console/write DEO
|
||||
INC2 !/<print>
|
||||
|
||||
(
|
||||
@|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
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue