lobo/kestrel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

add datetime device, revise device handling, remove tracing code

Browse source
This commit is contained in:
Lobo 2025-12-19 00:31:36 -03:00
parent 56a3398c8f
commit cf31dc5564
8 changed files with 115 additions and 119 deletions
Download patch file Download diff file Expand all files Collapse all files

35
lib/Device.ml
View file

@ -1,35 +1,12 @@
module Int_set = Set.Make (Int)
module type DEVICE = sig
type state
val state : state
val can_handle : int -> bool
val dei : Machine.machine -> int -> int option
val dei2 : Machine.machine -> int -> int option
val dei_ports : Int_set.t
val deo_ports : Int_set.t
val dei : Machine.machine -> int -> int
val dei2 : Machine.machine -> int -> int
val deo : Machine.machine -> int -> int -> unit
end
module Compose (D1 : DEVICE) (D2 : DEVICE) :
DEVICE with type state = D1.state * D2.state = struct
type state = D1.state * D2.state
let state = (D1.state, D2.state)
let can_handle port = D1.can_handle port || D2.can_handle port
let dei mach port =
match (D1.can_handle port, D2.can_handle port) with
| true, false -> D1.dei mach port
| false, true -> D2.dei mach port
| _ -> None
let dei2 mach port =
match (D1.can_handle port, D2.can_handle port) with
| true, false -> D1.dei2 mach port
| false, true -> D2.dei2 mach port
| _ -> None
let deo mach port value =
match (D1.can_handle port, D2.can_handle port) with
| true, false -> D1.deo mach port value
| false, true -> D2.deo mach port value
| _ -> ()
end

49
lib/Machine.ml
View file

@ -70,7 +70,6 @@ type _ Effect.t +=
| BRK : int Effect.t
| DEI : ([ `Byte | `Short ] * int) -> int Effect.t
| DEO : (int * int) -> unit Effect.t
| Trace : (int * Instr.t * int list) -> unit Effect.t
let ram (Machine { data; _ }) = data
let dev (Machine { dev; _ }) = dev
@ -85,13 +84,8 @@ let create code =
Bytes.blit_string code 0 data 0x100 (String.length code);
Machine { data; dev; stack = stack_create (); callstack = stack_create () }
let dispatch ?(trace = false) (Machine m) (pc : int) =
let dispatch (Machine m) (pc : int) =
let pc = ref pc in
let trace op l =
if trace then
let instr = Instr.of_int op in
perform (Trace (!pc, instr, l))
in
while true do
let op = Bytes.get_uint8 m.data (!pc land 0xffff) in
@ -107,35 +101,28 @@ let dispatch ?(trace = false) (Machine m) (pc : int) =
| 0x20 (* JCI *) ->
let cond = pop1 m.stack in
let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
trace op [ Bytes.get_uint16_be m.data !pc; cond ];
if cond != 0 then pc := !pc + addr + 2 else pc := !pc + 2
| 0x40 (* JMI *) ->
let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
trace op [ Bytes.get_uint16_be m.data !pc ];
pc := !pc + addr + 2
| 0x60 (* JSI *) ->
let addr = Util.get_int16_wrap ~wrap:0xffff m.data !pc in
trace op [ Bytes.get_uint16_be m.data !pc ];
push2 m.callstack (!pc + 2);
pc := !pc + addr + 2
| 0x80 (* LIT *) ->
let lit = Bytes.get_uint8 m.data !pc in
trace op [ lit ];
push1 m.stack lit;
pc := !pc + 1
| 0xa0 (* LIT2 *) ->
let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
trace op [ lit ];
push2 m.stack lit;
pc := !pc + 2
| 0xc0 (* LITr *) ->
let lit = Bytes.get_uint8 m.data !pc in
trace op [ lit ];
push1 m.callstack lit;
pc := !pc + 1
| 0xe0 (* LIT2r *) ->
let lit = Util.get_uint16_wrap ~wrap:0xffff m.data !pc in
trace op [ lit ];
push2 m.callstack lit;
pc := !pc + 2
| _ -> begin
@ -147,166 +134,136 @@ let dispatch ?(trace = false) (Machine m) (pc : int) =
match[@warning "-8"] opcode with
| 0x01 (* INC *) ->
let r = pop mode stk in
trace op [ r ];
push mode stk (r + 1)
| 0x02 (* POP *) -> trace op [ pop mode stk ]
| 0x02 (* POP *) -> ignore (pop mode stk)
| 0x03 (* NIP *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
ignore (pop mode stk);
push mode stk b
| 0x04 (* SWP *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk b;
push mode stk a
| 0x05 (* ROT *) ->
let c = pop mode stk in
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b; c ];
push mode stk b;
push mode stk c;
push mode stk a
| 0x06 (* DUP *) ->
let a = pop mode stk in
trace op [ a ];
push mode stk a;
push mode stk a
| 0x07 (* OVR *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk a;
push mode stk b;
push mode stk a
| 0x08 (* EQU *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
pushbyte mode stk (if a = b then 1 else 0)
| 0x09 (* NEQ *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
pushbyte mode stk (if a != b then 1 else 0)
| 0x0a (* GTH *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
pushbyte mode stk (if a > b then 1 else 0)
| 0x0b (* LTH *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
pushbyte mode stk (if a < b then 1 else 0)
| 0x0c (* JMP *) ->
let addr = pop mode stk in
trace op [ addr ];
if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
| 0x0d (* JCN *) ->
let addr = pop mode stk in
let cond = popbyte mode stk in
trace op [ cond; addr ];
if cond != 0 then
if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
| 0x0e (* JSR *) ->
push2 m.callstack !pc;
let addr = pop mode stk in
trace op [ addr ];
if short then pc := addr else pc := !pc + Util.uint8_to_int8 addr
| 0x0f (* STH *) ->
let a = pop mode stk in
trace op [ a ];
push mode stk' a
| 0x10 (* LDZ *) ->
let addr = popbyte mode stk in
trace op [ addr ];
push mode stk
(if short then Util.get_uint16_wrap m.data addr
else Bytes.get_uint8 m.data addr)
| 0x11 (* STZ *) ->
let addr = popbyte mode stk in
let v = pop mode stk in
trace op [ v; addr ];
if short then Util.set_uint16_wrap m.data addr v
else Bytes.set_uint8 m.data addr v
| 0x12 (* LDR *) ->
let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in
trace op [ addr ];
push mode stk
(if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr
else Bytes.get_uint8 m.data addr)
| 0x13 (* STR *) ->
let addr = !pc + Util.uint8_to_int8 (popbyte mode stk) in
let v = pop mode stk in
trace op [ v; addr ];
if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v
else Bytes.set_uint8 m.data addr v
| 0x14 (* LDA *) ->
let addr = popshort mode stk in
trace op [ addr ];
push mode stk
(if short then Util.get_uint16_wrap ~wrap:0xffff m.data addr
else Bytes.get_uint8 m.data addr)
| 0x15 (* STA *) ->
let addr = popshort mode stk in
let v = pop mode stk in
trace op [ v; addr ];
if short then Util.set_uint16_wrap ~wrap:0xffff m.data addr v
else Bytes.set_uint8 m.data addr v
| 0x16 (* DEI *) ->
let port = popbyte mode stk in
trace op [ port ];
push mode stk
(perform (DEI ((if short then `Short else `Byte), port)))
| 0x17 (* DEO *) ->
let port = popbyte mode stk in
let value = pop mode stk in
trace op [ value; port ];
if short then Util.set_uint16_wrap m.dev port value
else Bytes.set_uint8 m.dev port value;
perform (DEO (port, value))
| 0x18 (* ADD *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a + b)
| 0x19 (* SUB *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a - b)
| 0x1a (* MUL *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a * b)
| 0x1b (* DIV *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (if b = 0 then 0 else a / b)
| 0x1c (* AND *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a land b)
| 0x1d (* ORA *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a lor b)
| 0x1e (* EOR *) ->
let b = pop mode stk in
let a = pop mode stk in
trace op [ a; b ];
push mode stk (a lxor b)
| 0x1f (* SFT *) ->
let sft = popbyte mode stk in
let value = pop mode stk in
trace op [ value; sft ];
push mode stk ((value lsr (sft land 0xf)) lsl sft lsr 4)
end
done

3
lib/Machine.mli
View file

@ -17,7 +17,6 @@ type _ Effect.t +=
| BRK : int Effect.t
| DEI : ([ `Byte | `Short ] * int) -> int Effect.t
| DEO : (int * int) -> unit Effect.t
| Trace : (int * Instr.t * int list) -> unit Effect.t
val create : string -> machine
val dispatch : ?trace:bool -> machine -> int -> 'a
val dispatch : machine -> int -> 'a

9
lib/Varvara/Console.ml
View file

@ -4,9 +4,10 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
type nonrec state = state
let state = { console_vector = 0 }
let can_handle port = port >= 0x10 && port <= 0x1f
let dei _ _ = None
let dei2 _ _ = None
let dei_ports = Uxn.Device.Int_set.empty
let deo_ports = Uxn.Device.Int_set.of_list [ 0x10; 0x18; 0x19 ]
let dei _ _ = assert false
let dei2 _ _ = assert false
let deo _ port value =
match port with
@ -17,5 +18,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
| 0x19 ->
prerr_char (Char.chr value);
Out_channel.flush stderr
| _ -> ()
| _ -> assert false
end

34
lib/Varvara/Datetime.ml Normal file
View file

@ -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

19
lib/Varvara/File.ml
View file

@ -19,7 +19,18 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
type nonrec state = state
let state = { filepath = None; state = Idle; length = 0 }
let can_handle port = port >= Addr.start && port <= Addr.start + 0x0f
let dei_ports = Uxn.Device.Int_set.empty
let deo_ports =
Uxn.Device.Int_set.of_list
[
Addr.start + 0x0a;
Addr.start + 0x04;
Addr.start + 0x06;
Addr.start + 0x08;
Addr.start + 0x0c;
Addr.start + 0x0e;
]
let read_cstring ram addr =
let buf = Buffer.create 256 in
@ -194,8 +205,8 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
with Unix.Unix_error _ -> -1)
let file_success dev port value = Bytes.set_uint16_be dev port value
let dei _ _ = None
let dei2 _ _ = None
let dei _ _ = assert false
let dei2 _ _ = assert false
let deo mach port value =
let open Uxn in
@ -211,5 +222,5 @@ module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = state = struct
| 0x0e ->
let append = Bytes.get_uint8 dev (Addr.start + 0x07) in
file_write ram value state.length append |> with_success
| _ -> ()
| _ -> failwith (Printf.sprintf "%02x" port)
end

13
lib/Varvara/System.ml
View file

@ -6,7 +6,8 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
type nonrec state = state
let state = { banks = Array.init 15 (fun _ -> Bytes.create 65536) }
let can_handle port = port >= 0x00 && port <= 0x0f
let dei_ports = Uxn.Device.Int_set.of_list [ 0x04; 0x05 ]
let deo_ports = Uxn.Device.Int_set.of_list [ 0x02; 0x04; 0x05; 0x0e; 0x0f ]
let print_stack ~name (Machine.Stack { data; sp }) =
Printf.eprintf "%s " name;
@ -76,13 +77,13 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
match port with
| 0x04 ->
let (Machine.Stack { sp; _ }) = Machine.wst m in
Some sp
sp
| 0x05 ->
let (Machine.Stack { sp; _ }) = Machine.rst m in
Some sp
| _ -> None
sp
| _ -> assert false
let dei2 _ _ = None
let dei2 _ _ = assert false
let deo mach port value =
match port with
@ -100,5 +101,5 @@ module Make () : Uxn.Device.DEVICE with type state = state = struct
Out_channel.flush stderr
end
| 0x0f -> Bytes.set_uint8 (Machine.dev mach) 0x0f value
| _ -> ()
| _ -> assert false
end