coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/loops/tcl' into architecture

Browse Source
This commit is contained in:
giles
2026-05-07 18:29:26 +00:00
parent e0d447e2ce 63ad4563cb
commit 64157e9e81
4 changed files with 481 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

250
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -3124,6 +3124,108 @@ let () =
| [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
| _ -> raise (Eval_error "file-glob: (pattern)"));
(* === File metadata + ops (Phase 5d) === *)
let stat_or = function
| String path -> (try Some (Unix.stat path) with _ -> None)
| _ -> raise (Eval_error "file: path must be a string")
in
register "file-size" (fun args ->
match args with
| [v] -> (match stat_or v with Some s -> Integer s.Unix.st_size | None -> Integer 0)
| _ -> raise (Eval_error "file-size: (path)"));
register "file-mtime" (fun args ->
match args with
| [v] -> (match stat_or v with Some s -> Integer (int_of_float s.Unix.st_mtime) | None -> Integer 0)
| _ -> raise (Eval_error "file-mtime: (path)"));
register "file-isfile?" (fun args ->
match args with
| [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_REG) | None -> Bool false)
| _ -> raise (Eval_error "file-isfile?: (path)"));
register "file-isdir?" (fun args ->
match args with
| [v] -> (match stat_or v with Some s -> Bool (s.Unix.st_kind = Unix.S_DIR) | None -> Bool false)
| _ -> raise (Eval_error "file-isdir?: (path)"));
register "file-readable?" (fun args ->
match args with
| [String path] ->
Bool (try Unix.access path [Unix.R_OK]; true with _ -> false)
| _ -> raise (Eval_error "file-readable?: (path)"));
register "file-writable?" (fun args ->
match args with
| [String path] ->
Bool (try Unix.access path [Unix.W_OK]; true with _ -> false)
| _ -> raise (Eval_error "file-writable?: (path)"));
register "file-stat" (fun args ->
match args with
| [v] ->
(match stat_or v with
| None -> Nil
| Some s ->
let d = Hashtbl.create 6 in
Hashtbl.replace d "size" (Integer s.Unix.st_size);
Hashtbl.replace d "mtime" (Integer (int_of_float s.Unix.st_mtime));
Hashtbl.replace d "atime" (Integer (int_of_float s.Unix.st_atime));
Hashtbl.replace d "ctime" (Integer (int_of_float s.Unix.st_ctime));
Hashtbl.replace d "mode" (Integer s.Unix.st_perm);
Hashtbl.replace d "type" (String (match s.Unix.st_kind with
| Unix.S_REG -> "file" | Unix.S_DIR -> "directory"
| Unix.S_LNK -> "link" | Unix.S_CHR -> "characterSpecial"
| Unix.S_BLK -> "blockSpecial" | Unix.S_FIFO -> "fifo"
| Unix.S_SOCK -> "socket"));
Dict d)
| _ -> raise (Eval_error "file-stat: (path)"));
register "file-delete" (fun args ->
match args with
| [String path] ->
(try
if Sys.is_directory path then Unix.rmdir path
else Unix.unlink path
with
| Unix.Unix_error (Unix.ENOENT, _, _) -> () (* tolerate missing *)
| Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-delete: " ^ Unix.error_message e)));
Nil
| _ -> raise (Eval_error "file-delete: (path)"));
register "file-mkdir" (fun args ->
match args with
| [String path] ->
let rec mk p =
if p = "" || p = "." || p = "/" then ()
else if Sys.file_exists p then ()
else begin
mk (Filename.dirname p);
(try Unix.mkdir p 0o755
with Unix.Unix_error (Unix.EEXIST, _, _) -> ())
end
in
(try mk path
with Unix.Unix_error (e, _, _) -> raise (Eval_error ("file-mkdir: " ^ Unix.error_message e)));
Nil
| _ -> raise (Eval_error "file-mkdir: (path)"));
register "file-copy" (fun args ->
match args with
| [String src; String dst] ->
(try
let ic = open_in_bin src in
let oc = open_out_bin dst in
let buf = Bytes.create 8192 in
let rec loop () =
let n = input ic buf 0 (Bytes.length buf) in
if n > 0 then (output oc buf 0 n; loop ())
in
loop ();
close_in ic;
close_out oc;
Nil
with
| Sys_error msg -> raise (Eval_error ("file-copy: " ^ msg)))
| _ -> raise (Eval_error "file-copy: (src dst)"));
register "file-rename" (fun args ->
match args with
| [String src; String dst] ->
(try Sys.rename src dst with Sys_error msg -> raise (Eval_error ("file-rename: " ^ msg)));
Nil
| _ -> raise (Eval_error "file-rename: (src dst)"));
(* === Channels (random-access + blocking control) === *)
let channel_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in
let channel_next_id = ref 0 in
@@ -3337,6 +3439,43 @@ let () =
String name
| _ -> raise (Eval_error "socket-connect: (host port)"));
(* Non-blocking connect: returns channel immediately. Connection completes
when the channel becomes writable; query channel-async-error? after to
confirm success or get the error. *)
register "socket-connect-async" (fun args ->
match args with
| [String host; port_v] ->
let port = port_of port_v in
let addr = Unix.ADDR_INET (resolve_inet_addr host, port) in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.set_nonblock sock;
(try Unix.connect sock addr
with
| Unix.Unix_error (Unix.EINPROGRESS, _, _)
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> ()
| Unix.Unix_error (e, _, _) ->
(try Unix.close sock with _ -> ());
raise (Eval_error ("socket-connect-async: " ^ Unix.error_message e)));
let name = alloc_chan_name () in
Hashtbl.replace channel_table name (sock, "rw", ref false, ref false);
String name
| _ -> raise (Eval_error "socket-connect-async: (host port)"));
(* After a non-blocking connect completes (channel writable), check whether
the connect succeeded. Returns "" on success, error message on failure. *)
register "channel-async-error" (fun args ->
match args with
| [String name] ->
let (fd, _, _, _) = chan_get name in
(try
let err = Unix.getsockopt_error fd in
match err with
| None -> String ""
| Some e -> String (Unix.error_message e)
with
| Unix.Unix_error (e, _, _) -> String (Unix.error_message e))
| _ -> raise (Eval_error "channel-async-error: (channel)"));
register "socket-server" (fun args ->
let (host, port) = match args with
| [port_v] -> ("", port_of port_v)
@@ -3432,11 +3571,8 @@ let () =
| [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
| _ -> raise (Eval_error "clock-milliseconds: no args"));
register "clock-format" (fun args ->
match args with
| [Integer t] | [Integer t; String _] ->
let fmt = (match args with [_; String f] -> f | _ -> "%a %b %e %H:%M:%S %Z %Y") in
let tm = Unix.gmtime (float_of_int t) in
let format_tm tm tz_label =
fun fmt ->
let buf = Buffer.create 32 in
let n = String.length fmt in
let i = ref 0 in
@@ -3444,14 +3580,19 @@ let () =
if fmt.[!i] = '%' && !i + 1 < n then begin
(match fmt.[!i + 1] with
| 'Y' -> Buffer.add_string buf (Printf.sprintf "%04d" (1900 + tm.Unix.tm_year))
| 'y' -> Buffer.add_string buf (Printf.sprintf "%02d" ((1900 + tm.Unix.tm_year) mod 100))
| 'm' -> Buffer.add_string buf (Printf.sprintf "%02d" (tm.Unix.tm_mon + 1))
| 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
| 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" tm.Unix.tm_mday)
| 'H' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_hour)
| 'I' -> let h = tm.Unix.tm_hour mod 12 in
Buffer.add_string buf (Printf.sprintf "%02d" (if h = 0 then 12 else h))
| 'p' -> Buffer.add_string buf (if tm.Unix.tm_hour < 12 then "AM" else "PM")
| 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
| 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec)
| 'j' -> Buffer.add_string buf (Printf.sprintf "%03d" (tm.Unix.tm_yday + 1))
| 'Z' -> Buffer.add_string buf "UTC"
| 'w' -> Buffer.add_string buf (string_of_int tm.Unix.tm_wday)
| 'Z' -> Buffer.add_string buf tz_label
| 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in
@@ -3460,6 +3601,7 @@ let () =
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| 'B' -> let mons = [|"January";"February";"March";"April";"May";"June";"July";"August";"September";"October";"November";"December"|] in
Buffer.add_string buf mons.(tm.Unix.tm_mon)
| '%' -> Buffer.add_char buf '%'
| c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
i := !i + 2
end else begin
@@ -3467,8 +3609,100 @@ let () =
incr i
end
done;
String (Buffer.contents buf)
| _ -> raise (Eval_error "clock-format: (seconds [format])"));
Buffer.contents buf
in
register "clock-format" (fun args ->
let (t, fmt, tz) = match args with
| [Integer t] -> (t, "%a %b %e %H:%M:%S %Z %Y", "utc")
| [Integer t; String f] -> (t, f, "utc")
| [Integer t; String f; String z] -> (t, f, z)
| _ -> raise (Eval_error "clock-format: (seconds [format [tz]])")
in
let tm =
if tz = "local" then Unix.localtime (float_of_int t)
else Unix.gmtime (float_of_int t)
in
let label = if tz = "local" then "" else "UTC" in
String (format_tm tm label fmt));
(* clock-scan: parse a date string with format, return seconds.
Supports the same format specifiers as clock-format (fixed-width ones).
tz: "utc" (default) or "local". *)
let timegm (tm : Unix.tm) =
let is_leap y = y mod 4 = 0 && (y mod 100 <> 0 || y mod 400 = 0) in
let days_in_month = [|31;28;31;30;31;30;31;31;30;31;30;31|] in
let year = tm.Unix.tm_year + 1900 in
let mon = tm.Unix.tm_mon in
let mday = tm.Unix.tm_mday in
let total_days = ref 0 in
if year >= 1970 then begin
for y = 1970 to year - 1 do
total_days := !total_days + (if is_leap y then 366 else 365)
done
end else begin
for y = year to 1969 do
total_days := !total_days - (if is_leap y then 366 else 365)
done
end;
for m = 0 to mon - 1 do
total_days := !total_days + days_in_month.(m);
if m = 1 && is_leap year then incr total_days
done;
total_days := !total_days + mday - 1;
!total_days * 86400
+ tm.Unix.tm_hour * 3600
+ tm.Unix.tm_min * 60
+ tm.Unix.tm_sec
in
register "clock-scan" (fun args ->
let (str, fmt, tz) = match args with
| [String s; String f] -> (s, f, "utc")
| [String s; String f; String z] -> (s, f, z)
| _ -> raise (Eval_error "clock-scan: (str fmt [tz])")
in
let n = String.length fmt and sn = String.length str in
let tm = ref { Unix.tm_year = 70; tm_mon = 0; tm_mday = 1;
tm_hour = 0; tm_min = 0; tm_sec = 0;
tm_wday = 0; tm_yday = 0; tm_isdst = false } in
let i = ref 0 and j = ref 0 in
let read_n_digits k =
let s = ref "" in
let cnt = ref 0 in
while !cnt < k && !j < sn && str.[!j] >= '0' && str.[!j] <= '9' do
s := !s ^ String.make 1 str.[!j];
incr j; incr cnt
done;
if !s = "" then 0 else int_of_string !s
in
let skip_ws () =
while !j < sn && (str.[!j] = ' ' || str.[!j] = '\t') do incr j done
in
while !i < n do
if fmt.[!i] = '%' && !i + 1 < n then begin
(match fmt.[!i + 1] with
| 'Y' -> tm := { !tm with tm_year = read_n_digits 4 - 1900 }
| 'y' -> let y = read_n_digits 2 in
tm := { !tm with tm_year = (if y < 70 then 100 + y else y) }
| 'm' -> tm := { !tm with tm_mon = read_n_digits 2 - 1 }
| 'd' | 'e' -> skip_ws (); tm := { !tm with tm_mday = read_n_digits 2 }
| 'H' | 'I' -> tm := { !tm with tm_hour = read_n_digits 2 }
| 'M' -> tm := { !tm with tm_min = read_n_digits 2 }
| 'S' -> tm := { !tm with tm_sec = read_n_digits 2 }
| '%' -> if !j < sn && str.[!j] = '%' then incr j
| _ -> () (* unsupported specifier — skip *)
);
i := !i + 2
end else begin
if fmt.[!i] = ' ' then skip_ws ()
else if !j < sn && str.[!j] = fmt.[!i] then incr j;
incr i
end
done;
let secs =
if tz = "local" then int_of_float (fst (Unix.mktime !tm))
else timegm !tm
in
Integer secs);
(* === Env-as-value (Phase 4) === *)