231 lines
7.4 KiB
OCaml
231 lines
7.4 KiB
OCaml
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) : Kestrel.Device.DEVICE with type state = state =
|
|
struct
|
|
type nonrec state = state
|
|
|
|
let state = { filepath = None; state = Idle; length = 0 }
|
|
let dei_ports = Kestrel.Device.Int_set.empty
|
|
|
|
let deo_ports =
|
|
Kestrel.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 Kestrel 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
|