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

move File device to new module system

Browse source
This commit is contained in:
Lobo 2025-12-18 14:24:20 -03:00
parent 5769f6d470
commit b71cf4343e
4 changed files with 291 additions and 226 deletions
Download patch file Download diff file Expand all files Collapse all files

68
exe/uxnemu.ml
View file

@ -5,7 +5,18 @@ let trace = Option.is_some (Sys.getenv_opt "UXNEMU_DEBUG")
module System = Varvara.System.Make () module System = Varvara.System.Make ()
module Console = Varvara.Console.Make () module Console = Varvara.Console.Make ()
module Devices = Uxn.Device.Compose (System) (Console)
module File =
Uxn.Device.Compose
(Varvara.File.Make (struct
let start_addr = 0xa0
end))
(Varvara.File.Make (struct
let start_addr = 0xb0
end))
module Devices =
Uxn.Device.Compose (Uxn.Device.Compose (System) (Console)) (File)
let print_stack ~name (Machine.Stack { data; sp }) = let print_stack ~name (Machine.Stack { data; sp }) =
Fmt.epr "%s: @[%a@]@." name Fmt.epr "%s: @[%a@]@." name
@ -14,7 +25,6 @@ let print_stack ~name (Machine.Stack { data; sp }) =
let run m pc = let run m pc =
let dev = Machine.dev m in let dev = Machine.dev m in
let ram = Machine.ram m in
try Machine.dispatch ~trace m pc with try Machine.dispatch ~trace m pc with
| effect Machine.Trace (pc, instr, args), k -> | effect Machine.Trace (pc, instr, args), k ->
if trace then begin if trace then begin
@ -34,62 +44,12 @@ let run m pc =
| Some v -> continue k v | Some v -> continue k v
| None -> continue k (Util.get_uint16_wrap dev port)) | None -> continue k (Util.get_uint16_wrap dev port))
| effect Machine.DEO (port, value), k -> | effect Machine.DEO (port, value), k ->
(match port with if Devices.can_handle port then Devices.deo m port value;
| _ when Devices.can_handle port -> Devices.deo m port value
| 0xaa -> Varvara.File.file_lengths.(0) <- Bytes.get_uint16_be dev 0xaa
| 0xa4 ->
let addr = Bytes.get_uint16_be dev 0xa4 in
let len = Varvara.File.file_lengths.(0) in
let result = Varvara.File.file_stat ram 0 addr len in
Varvara.File.file_success dev 0xa2 result
| 0xa6 ->
let result = Varvara.File.file_delete 0 in
Varvara.File.file_success dev 0xa2 (if result = 0 then 1 else 0)
| 0xa8 ->
let addr = Bytes.get_uint16_be dev 0xa8 in
let result = Varvara.File.file_init ram 0 addr in
Varvara.File.file_success dev 0xa2 result
| 0xac ->
let addr = Bytes.get_uint16_be dev 0xac in
let len = Varvara.File.file_lengths.(0) in
let result = Varvara.File.file_read ram 0 addr len in
Varvara.File.file_success dev 0xa2 result
| 0xae ->
let addr = Bytes.get_uint16_be dev 0xae in
let len = Varvara.File.file_lengths.(0) in
let append = Bytes.get_uint8 dev 0xa7 in
let result = Varvara.File.file_write ram 0 addr len append in
Varvara.File.file_success dev 0xa2 result
| 0xba -> Varvara.File.file_lengths.(1) <- Bytes.get_uint16_be dev 0xba
| 0xb4 ->
let addr = Bytes.get_uint16_be dev 0xb4 in
let len = Varvara.File.file_lengths.(1) in
let result = Varvara.File.file_stat ram 1 addr len in
Varvara.File.file_success dev 0xb2 result
| 0xb6 ->
let result = Varvara.File.file_delete 1 in
Varvara.File.file_success dev 0xb2 (if result = 0 then 1 else 0)
| 0xb8 ->
let addr = Bytes.get_uint16_be dev 0xb8 in
let result = Varvara.File.file_init ram 1 addr in
Varvara.File.file_success dev 0xb2 result
| 0xbc ->
let addr = Bytes.get_uint16_be dev 0xbc in
let len = Varvara.File.file_lengths.(1) in
let result = Varvara.File.file_read ram 1 addr len in
Varvara.File.file_success dev 0xb2 result
| 0xbe ->
let addr = Bytes.get_uint16_be dev 0xbe in
let len = Varvara.File.file_lengths.(1) in
let append = Bytes.get_uint8 dev 0xb7 in
let result = Varvara.File.file_write ram 1 addr len append in
Varvara.File.file_success dev 0xb2 result
| _ -> ());
continue k () continue k ()
let main () = let main () =
if Array.length Sys.argv < 2 then ( if Array.length Sys.argv < 2 then (
Fmt.epr "usage: uxnemu file.rom\n"; Fmt.epr "usage: uxnemu file.rom ...\n";
exit 1); exit 1);
let code = let code =

361
lib/Varvara/File.ml
View file

@ -11,191 +11,210 @@ type file_device = {
mutable length : int; mutable length : int;
} }
let make_file () = { filepath = None; state = Idle; length = 0 } module type ADDR = sig
let file_devices = [| make_file (); make_file () |] val start_addr : int
let file_lengths = [| 0; 0 |] end
(* Read null-terminated string from RAM *) module Make (Addr : ADDR) : Uxn.Device.DEVICE with type state = file_device =
let read_cstring ram addr = struct
let buf = Buffer.create 256 in type state = file_device
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 = let state = { filepath = None; state = Idle; length = 0 }
(match dev.state with
| File_read ic -> close_in_noerr ic
| File_write oc -> close_out_noerr oc
| Dir_read (dh, _) -> Unix.closedir dh
| Idle | Dir_write -> ());
dev.state <- Idle
let file_init ram id addr = let can_handle port =
let dev = file_devices.(id) in port >= Addr.start_addr && port <= Addr.start_addr + 0x0f
file_reset dev;
dev.filepath <- Some (read_cstring ram addr);
0
let file_not_ready id = let read_cstring ram addr =
match file_devices.(id).filepath with let buf = Buffer.create 256 in
| None -> let rec loop pos =
Format.eprintf "File %d is uninitialized@." id; if pos >= Bytes.length ram then Buffer.contents buf
true else
| Some _ -> false let c = Bytes.get ram pos in
if c = '\x00' then Buffer.contents buf
else (
Buffer.add_char buf c;
loop (pos + 1))
in
loop addr
let format_size size len = let file_reset dev =
let hex_digits = "0123456789abcdef" in (match dev.state with
let buf = Bytes.create len in | File_read ic -> close_in_noerr ic
for i = 0 to len - 1 do | File_write oc -> close_out_noerr oc
let shift = 4 * (len - 1 - i) in | Dir_read (dh, _) -> Unix.closedir dh
let nibble = (size lsr shift) land 0xf in | Idle | Dir_write -> ());
Bytes.set buf i hex_digits.[nibble] dev.state <- Idle
done;
Bytes.to_string buf
let format_stat ?(capsize = false) filepath len = let file_init ram addr =
try file_reset state;
let st = Unix.stat filepath in state.filepath <- Some (read_cstring ram addr);
let is_dir = st.Unix.st_kind = Unix.S_DIR in 0
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 file_not_ready () = state.filepath |> Option.is_none
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 format_size size len =
let dh = Unix.opendir filepath in let hex_digits = "0123456789abcdef" in
let buf = Buffer.create 1024 in let buf = Bytes.create len in
let rec read_entries () = 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 try
let entry = Unix.readdir dh in let st = Unix.stat filepath in
if entry <> "." && entry <> ".." then let is_dir = st.Unix.st_kind = Unix.S_DIR in
Buffer.add_string buf (format_dir_entry filepath entry); if is_dir then String.make len '-'
if Buffer.length buf < maxlen then read_entries () else if capsize && st.Unix.st_size >= 0x10000 then String.make len '?'
with End_of_file -> () else format_size st.Unix.st_size len
in with Unix.Unix_error _ -> String.make len '!'
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 format_dir_entry filepath basename =
let rec mkdir_parents p = let full_path = Filename.concat filepath basename in
if p <> "" && p <> "." && p <> "/" then let stat_str = format_stat ~capsize:true full_path 4 in
if not (Sys.file_exists p) then ( try
mkdir_parents (Filename.dirname p); let st = Unix.stat full_path in
try Unix.mkdir p 0o755 with Unix.Unix_error _ -> ()) let is_dir = st.Unix.st_kind = Unix.S_DIR in
in Printf.sprintf "%s %s%s\n" stat_str basename (if is_dir then "/" else "")
mkdir_parents (Filename.dirname path) with Unix.Unix_error _ -> Printf.sprintf "%s %s\n" stat_str basename
let is_dir_path path = let read_directory filepath maxlen =
String.length path > 0 && path.[String.length path - 1] = '/' let dh = Unix.opendir filepath in
let buf = Buffer.create 1024 in
let rec read_entries () =
try
let entry = Unix.readdir dh in
if entry <> "." && entry <> ".." then
Buffer.add_string buf (format_dir_entry filepath entry);
if Buffer.length buf < maxlen then read_entries ()
with End_of_file -> ()
in
read_entries ();
Unix.closedir dh;
let result = Buffer.contents buf in
if String.length result > maxlen then String.sub result 0 maxlen else result
let file_read ram id addr len = let create_directories path =
if file_not_ready id then 0 let rec mkdir_parents p =
else if p <> "" && p <> "." && p <> "/" then
let dev = file_devices.(id) in if not (Sys.file_exists p) then (
match dev.filepath with mkdir_parents (Filename.dirname p);
| None -> 0 try Unix.mkdir p 0o755 with Unix.Unix_error _ -> ())
| Some filepath -> ( in
(match dev.state with mkdir_parents (Filename.dirname path)
| Idle ->
if Sys.is_directory filepath then
dev.state <- Dir_read (Unix.opendir filepath, filepath)
else dev.state <- File_read (open_in_bin filepath)
| _ -> ());
match dev.state with
| File_read ic -> (
try
let bytes_read = input ic ram addr len in
bytes_read
with
| End_of_file -> 0
| Sys_error _ -> 0)
| Dir_read (dh, fp) -> (
try
let contents = read_directory fp len in
let bytes_to_copy = min len (String.length contents) in
Bytes.blit_string contents 0 ram addr bytes_to_copy;
Unix.closedir dh;
dev.state <- Idle;
bytes_to_copy
with Unix.Unix_error _ -> 0)
| _ -> 0)
let file_write ram id addr len append_flag = let is_dir_path path =
if file_not_ready id then 0 String.length path > 0 && path.[String.length path - 1] = '/'
else
let dev = file_devices.(id) in let file_read ram addr len =
match dev.filepath with if file_not_ready () then 0
| None -> 0 else
| Some filepath -> ( match state.filepath with
(match dev.state with | None -> 0
| Idle -> | Some filepath -> (
if is_dir_path filepath then ( (match state.state with
create_directories filepath; | Idle ->
dev.state <- Dir_write) if Sys.is_directory filepath then
else ( state.state <- Dir_read (Unix.opendir filepath, filepath)
create_directories filepath; else state.state <- File_read (open_in_bin filepath)
let mode = | _ -> ());
if append_flag land 0x01 <> 0 then match state.state with
[ Open_wronly; Open_binary; Open_append; Open_creat ] | File_read ic -> (
else [ Open_wronly; Open_binary; Open_creat; Open_trunc ]
in
try try
let oc = open_out_gen mode 0o644 filepath in let bytes_read = input ic ram addr len in
dev.state <- File_write oc bytes_read
with Sys_error _ -> ()) with
| _ -> ()); | End_of_file -> 0
match dev.state with | Sys_error _ -> 0)
| File_write oc -> ( | Dir_read (dh, fp) -> (
try try
output oc ram addr len; let contents = read_directory fp len in
flush oc; let bytes_to_copy = min len (String.length contents) in
len Bytes.blit_string contents 0 ram addr bytes_to_copy;
with Sys_error _ -> 0) Unix.closedir dh;
| Dir_write -> state.state <- Idle;
if Sys.file_exists filepath && Sys.is_directory filepath then 1 bytes_to_copy
else 0 with Unix.Unix_error _ -> 0)
| _ -> 0) | _ -> 0)
let file_stat ram id addr len = let file_write ram addr len append_flag =
if file_not_ready id then 0 if file_not_ready () then 0
else else
let dev = file_devices.(id) in match state.filepath with
match dev.filepath with | None -> 0
| None -> 0 | Some filepath -> (
| Some filepath -> (match state.state with
let stat_str = format_stat filepath len in | Idle ->
let bytes_to_copy = min len (String.length stat_str) in if is_dir_path filepath then (
Bytes.blit_string stat_str 0 ram addr bytes_to_copy; create_directories filepath;
bytes_to_copy state.state <- Dir_write)
else (
create_directories filepath;
let mode =
if append_flag land 0x01 <> 0 then
[ Open_wronly; Open_binary; Open_append; Open_creat ]
else [ Open_wronly; Open_binary; Open_creat; Open_trunc ]
in
try
let oc = open_out_gen mode 0o644 filepath in
state.state <- File_write oc
with Sys_error _ -> ())
| _ -> ());
match state.state with
| File_write oc -> (
try
output oc ram addr len;
flush oc;
len
with Sys_error _ -> 0)
| Dir_write ->
if Sys.file_exists filepath && Sys.is_directory filepath then 1
else 0
| _ -> 0)
let file_delete id = let file_stat ram addr len =
if file_not_ready id then -1 if file_not_ready () then 0
else else
let dev = file_devices.(id) in match state.filepath with
match dev.filepath with | None -> 0
| None -> -1 | Some filepath ->
| Some filepath -> ( let stat_str = format_stat filepath len in
try let bytes_to_copy = min len (String.length stat_str) in
Unix.unlink filepath; Bytes.blit_string stat_str 0 ram addr bytes_to_copy;
0 bytes_to_copy
with Unix.Unix_error _ -> -1)
let file_success dev port value = Bytes.set_uint16_be dev port value let file_delete () =
if file_not_ready () then -1
else
match state.filepath with
| None -> -1
| Some filepath -> (
try
Unix.unlink filepath;
0
with Unix.Unix_error _ -> -1)
let file_success dev port value = Bytes.set_uint16_be dev port value
let dei _ _ = None
let dei2 _ _ = None
let deo mach port value =
let open Uxn in
let ram = Machine.ram mach in
let dev = Machine.dev mach in
let with_success result =
file_success dev (Addr.start_addr + 0x02) result
in
match port - Addr.start_addr with
| 0x0a -> state.length <- value
| 0x04 -> file_stat (Machine.ram mach) value state.length |> with_success
| 0x06 -> file_delete () |> with_success
| 0x08 -> file_init (Machine.ram mach) value |> with_success
| 0x0c -> file_read (Machine.ram mach) value state.length |> with_success
| 0x0e ->
let append = Bytes.get_uint8 dev (Addr.start_addr + 0x07) in
file_write ram value state.length append |> with_success
| _ -> ()
end

2
utils/Makefile
View file

@ -1,7 +1,7 @@
.PHONY: all clean .PHONY: all clean
.SUFFIXES: .tal .rom .SUFFIXES: .tal .rom
all: uxnmin drifloon.rom opctest.rom all: uxnmin drifloon.rom opctest.rom varvara.file.rom
clean: clean:
rm -f uxnmin drifloon.rom opctest.rom rm -f uxnmin drifloon.rom opctest.rom

86
utils/varvara.file.tal Normal file
View file

@ -0,0 +1,86 @@
( uxncli file.rom )
|10 @Console/vector $2 &read $1 &pad $4 &type $1 &write $1 &error $1
|a0 @File/vector $2 &success $2 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2
|100
@on-reset ( -> )
file/<create>
file/<load>
#0004 .File/success DEI2 NEQ2 ?fail
;file/a1 LDA2 ;file/a2 LDA2 NEQ2 ?fail
;dict/load str/<print>
;file/b1 LDA2 ;file/b2 LDA2 NEQ2 ?fail
;dict/append str/<print>
;file/stat-buf file/<stat>
;file/stat-hs LDA2 LIT2 "00 NEQ2 ?fail
;file/stat-ls LDA2 LIT2 "04 NEQ2 ?fail
;dict/stat str/<print>
file/<delete>
;file/null-buf file/<stat>
;file/null-buf LDA2 LIT2 "!! NEQ2 ?fail
;dict/delete str/<print>
#800f DEO
BRK
@fail ( -> )
;dict/failed str/<print>
#010f DEO
BRK
(
@|File )
@file/<create> ( -- )
;&name .File/name DEO2
#0002 .File/length DEO2
;&a1 .File/write DEO2
( | append )
;&name .File/name DEO2
#0002 .File/length DEO2
#01 .File/append DEO
;&b1 .File/write DEO2
JMP2r
@file/<load> ( -- )
;&name .File/name DEO2
( two more bytes than max length ) #0006 .File/length DEO2
;&load-buf .File/read DEO2
JMP2r
@file/<stat> ( buf* -- )
;&name .File/name DEO2
#0004 .File/length DEO2
.File/stat DEO2
JMP2r
@file/<delete> ( -- )
;&name .File/name DEO2
#01 .File/delete DEO
JMP2r
&name "test.txt $1
(
@|Utils )
@str/<print> ( str* -- )
LDAk DUP ?{ POP POP2 JMP2r }
#18 DEO
INC2 !/<print>
(
@|Data )
@dict/failed "File: 20 "fail 0a $1
&load "File/load: 20 "pass 0a $1
&append "File/append: 20 "pass 0a $1
&stat "File/stat: 20 "pass 0a $1
&delete "File/delete: 20 "pass 0a $1
@file/data &a1 1234 &b1 5678
( load buf ) &load-buf &a2 $2 &b2 $2
( stat buf ) &stat-buf &stat-hs $2 &stat-ls $2
( null buf ) &null-buf $4