9 Commits

Author SHA1 Message Date
50b69bcbd0 tcl: fix Phase 7d oo tests using ::name-with-hyphens
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 51s
Tcl tokenizer treats $::g-name as $::g + literal -name, so the var
lookup fails. Renamed test vars to ::gname / ::nval (no hyphens).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 22:49:23 +00:00
14986d787d tcl: Phase 7 — try/trap, exec pipelines, string audit, regexp, TclOO [WIP]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
7a try/trap: tcl-cmd-try extended with `trap pattern varlist body` clause
   matching errorcode prefix. Handler varlist supports {result optsdict}.
   Added tcl-try-trap-matches?, tcl-try-build-opts helpers.

7b exec pipelines: new exec-pipeline SX primitive parses `|`, `< file`,
   `> file`, `>> file`, `2> file`, `2>@1` and builds a process pipeline
   via Unix.pipe + create_process. tcl-cmd-exec dispatches to it on
   metachar presence.

7c string audit: added string equal (-nocase, -length), totitle, reverse,
   replace; added string is true/false/xdigit/ascii classes.

7d TclOO: minimal `oo::class create NAME body` with method/constructor/
   destructor/superclass; instances via `Cls new ?args?`; method dispatch
   via per-object Tcl command; single inheritance via :super chain.
   Stored in interp :classes / :oo-objects / :oo-counter.

7e regexp audit: existing Re.Pcre wrapper handles ^/$ anchors, \\b
   boundaries, -nocase, captures, regsub -all. Added regression tests.

+22 idiom tests (5 try, 5 exec pipeline, 7 string, 6 regexp, 5 TclOO).

[WIP — full suite verification pending]

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 22:45:16 +00:00
21028c4fb0 tcl: rename tcl-vwait-lookup → tcl-var-lookup-or-nil; use in info exists
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 51s
Generalized helper for var-lookup-with-:: so info exists also works on
::-prefixed names.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 09:32:44 +00:00
7415dd020e tcl: Phase 6a fix vwait :: routing — was infinite-looping
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 55s
vwait used frame-lookup which doesn't honor `::` global routing. So
`vwait ::done` after `set ::done fired` (where set routes to root frame)
never saw the var change in the local frame, looping forever.

Added tcl-vwait-lookup helper that mirrors tcl-var-get's `::` routing
but returns nil instead of erroring on missing vars.

Was the deadlock that hung the full test suite past test 32.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 09:30:51 +00:00
2fa0bb4df1 tcl: Phase 6 — namespace, list ops, dict additions, scan/format, exec [WIP]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Phase 6a (namespace `::` prefix):
- tcl-global-ref?/strip-global helpers
- tcl-var-get/set route ::name to root frame
- tokenizer parse-var-sub accepts `::` start so $::var works
- tcl-call-proc forwards :fileevents/:timers/:procs/:commands
- char-at fast-path optimization on var-get/set hot path

Phase 6b (list ops): added lassign, lrepeat, lset, lmap.

Phase 6c (dict additions): added dict lappend, remove, filter -key.

Phase 6d (scan/format):
- printf-spec SX primitive wrapping OCaml Printf via Scanf.format_from_string
- scan-spec SX primitive (manual scanner for d/i/u/x/X/o/c/s/f/e/g)
- Tcl format dispatches via printf-spec; tcl-cmd-scan walks fmt and dispatches

Phase 6e (exec):
- exec-process SX primitive wraps Unix.create_process + waitpid
- Tcl `exec cmd arg...` returns trimmed stdout; raises on non-zero exit

test.sh inner timeout 3600s → 7200s (post-merge JIT recursion is slow).

+27 idiom tests covering ns, list ops, dict, format, scan, exec.

[WIP — full suite verification still pending]

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 08:28:05 +00:00
63ad4563cb tcl: Phase 5d/5e/5f — file ops, clock locale+scan, socket -async
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
Phase 5d (file metadata + ops):
- 11 SX primitives: file-size/mtime/stat/isfile?/isdir?/readable?/writable?/
  delete/mkdir/copy/rename — wrap Unix.stat/access/unlink/mkdir/rename
- Tcl `file` subcommands real (were stubs): isfile, isdir, readable,
  writable, size, mtime, atime, type, mkdir, copy, rename, delete
- file delete/copy/rename strip leading-`-` flags
- +10 idiom tests

Phase 5e (clock options + scan):
- clock-format extended to (t fmt tz), tz ∈ utc|local
- Added specifiers: %y, %I, %p, %w, %%
- New clock-scan SX primitive — format-driven parser + manual timegm
- Tcl clock format/scan accept -format, -timezone, -gmt 0|1
- +5 idiom tests

Phase 5f (socket -async):
- socket-connect-async SX primitive: Unix.set_nonblock + connect, catches
  EINPROGRESS; returns channel immediately
- channel-async-error: Unix.getsockopt_error
- Tcl `socket -async host port`; `fconfigure $sock -error`
- Connection completes on writable; canonical fileevent pattern works
- +3 idiom tests

Bug fix: tcl-call-proc was discarding :fileevents/:timers/:procs updates
made inside Tcl procs (only :commands forwarded). Now forwards full
result-interp as base, restoring caller's frame/stack/result/output/code.
This was masked until socket-async made fileevent-from-inside-proc the
natural pattern.

test.sh inner timeout bumped 1200s→2400s (post-merge JIT remains slow).

376/376 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-07 18:28:49 +00:00
c8b232d40e tcl: Phase 5c TCP sockets — client + server
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m4s
Three new SX primitives wrapping Unix socket APIs:
- socket-connect host port → "sockN" (TCP client)
- socket-server ?host? port → "sockN" listening socket (SO_REUSEADDR, backlog 8)
- socket-accept server-chan → {:channel :host :port}

Sockets reuse the channel_table from Phase 5, so existing channel-read/
write/close/select all work on them. Host arg supports localhost,
0.0.0.0, IPv4 literal, or gethostbyname lookup.

Tcl `socket` command:
- socket host port → TCP client
- socket -server cb port → listening socket; auto-registers a fileevent
  on the server channel that fires `_sock-do-accept SRV CB` per readable
  event. _sock-do-accept (internal) accepts the pending client and calls
  the user's callback as `cb client-chan host port`.

puts channel detection now also recognizes "sockN" prefix (was only
"fileN") and dispatches to channel-write.

+4 idiom tests: socket-server-fires-callback, socket-client-server-
roundtrip, socket-server-peer-host, socket-multiple-connections.
358/358 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-07 16:50:06 +00:00
64d36fa66e tcl: Phase 5b event loop — fileevent/after/vwait/update
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s
New SX primitive io-select-channels(read-list write-list timeout-ms) wrapping
Unix.select on the registered channel table. Returns {:readable :writable}.

Tcl event loop implemented purely in Tcl (no sx_server.ml changes):
- fileevent $chan readable|writable script (or "" to unregister)
- fileevent $chan event (1 arg) returns the registered script
- after ms script — schedule one-shot timer
- after ms (no script) — sleep, driving event loop in the meantime
- vwait varname — block until var is set/changed, handlers run between polls
- update — non-blocking event drain (poll-timeout=0)

State on interp: :fileevents (list of (chan event script)) and :timers
(sorted list of (expiry-ms script)).

tcl-event-step is the inner loop: expire timers, build fd lists from
:fileevents, call io-select-channels with computed timeout, run ready
handlers. vwait polls every 1000ms or until var changes.

Scoped to script mode by design — vwait from inside a server-handled
command does not interact with sx_server's stdin scheduler.

+5 idiom tests: after-vwait-timer, after-multiple-timers-update,
fileevent-readable-fires, fileevent-query-script,
after-cancel-via-vwait-timing. 354/354 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-07 12:47:31 +00:00
be820d0337 tcl: Phase 5 channel I/O — open/read/gets/puts/seek/tell/eof/fconfigure
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 2m0s
11 new SX primitives in sx_primitives.ml wrapping Unix.openfile/read/write/
lseek/set_nonblock: channel-open/close/read/read-line/write/flush/seek/tell/
eof?/blocking?/set-blocking!.

Tcl runtime now uses real channel ops:
- open ?-mode? returns "fileN" handle (modes r/w/a/r+/w+/a+)
- close/read/gets/puts/seek/tell/eof/flush wired through
- new fconfigure command supports -blocking 0|1
- puts dispatches to channel-write when first arg starts with "file"
- gets command registration fixed (was pointing to old stub)

eof-returns-1 coro test updated to match real Tcl semantics (eof flips
only after a read hits EOF).

Test runner timeout bumped 180s→1200s (post-merge JIT is slow).

+7 idiom tests covering write+read, gets-loop, seek/tell, eof-after-read,
append mode, seek-to-end, fconfigure-blocking. 349/349 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-07 09:28:44 +00:00
6 changed files with 2902 additions and 254 deletions

View File

@@ -528,6 +528,183 @@ let () =
| [Rational (_, d)] -> Integer d
| [Integer _] -> Integer 1
| _ -> raise (Eval_error "denominator: expected rational or integer"));
(* printf-spec: apply one Tcl/printf format spec to one arg.
spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with %
and ends with the conversion char. Supports d i u x X o c s f e g.
Coerces arg to the right type per conversion. *)
register "printf-spec" (fun args ->
let spec_str, arg = match args with
| [String s; v] -> (s, v)
| _ -> raise (Eval_error "printf-spec: (spec arg)")
in
let n = String.length spec_str in
if n < 2 || spec_str.[0] <> '%' then
raise (Eval_error ("printf-spec: invalid spec " ^ spec_str));
let type_char = spec_str.[n - 1] in
let to_int v = match v with
| Integer i -> i
| Number f -> int_of_float f
| String s ->
let s = String.trim s in
(try int_of_string s
with _ ->
try int_of_float (float_of_string s)
with _ -> 0)
| Bool true -> 1 | Bool false -> 0
| _ -> 0
in
let to_float v = match v with
| Number f -> f
| Integer i -> float_of_int i
| String s ->
let s = String.trim s in
(try float_of_string s with _ -> 0.0)
| _ -> 0.0
in
let to_string v = match v with
| String s -> s
| Integer i -> string_of_int i
| Number f -> Sx_types.format_number f
| Bool true -> "1" | Bool false -> "0"
| Nil -> ""
| _ -> Sx_types.inspect v
in
try
match type_char with
| 'd' | 'i' ->
let fmt = Scanf.format_from_string spec_str "%d" in
String (Printf.sprintf fmt (to_int arg))
| 'u' ->
let fmt = Scanf.format_from_string spec_str "%u" in
String (Printf.sprintf fmt (to_int arg))
| 'x' ->
let fmt = Scanf.format_from_string spec_str "%x" in
String (Printf.sprintf fmt (to_int arg))
| 'X' ->
let fmt = Scanf.format_from_string spec_str "%X" in
String (Printf.sprintf fmt (to_int arg))
| 'o' ->
let fmt = Scanf.format_from_string spec_str "%o" in
String (Printf.sprintf fmt (to_int arg))
| 'c' ->
let n_val = to_int arg in
let body = String.sub spec_str 0 (n - 1) in
let fmt = Scanf.format_from_string (body ^ "s") "%s" in
String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff))))
| 's' ->
let fmt = Scanf.format_from_string spec_str "%s" in
String (Printf.sprintf fmt (to_string arg))
| 'f' ->
let fmt = Scanf.format_from_string spec_str "%f" in
String (Printf.sprintf fmt (to_float arg))
| 'e' ->
let fmt = Scanf.format_from_string spec_str "%e" in
String (Printf.sprintf fmt (to_float arg))
| 'E' ->
let fmt = Scanf.format_from_string spec_str "%E" in
String (Printf.sprintf fmt (to_float arg))
| 'g' ->
let fmt = Scanf.format_from_string spec_str "%g" in
String (Printf.sprintf fmt (to_float arg))
| 'G' ->
let fmt = Scanf.format_from_string spec_str "%G" in
String (Printf.sprintf fmt (to_float arg))
| _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char))
with
| Eval_error _ as e -> raise e
| _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str)));
(* scan-spec: apply one Tcl/scanf format spec to a string.
Returns (consumed-count . parsed-value), or nil on failure. *)
register "scan-spec" (fun args ->
let spec_str, str = match args with
| [String s; String input] -> (s, input)
| _ -> raise (Eval_error "scan-spec: (spec input)")
in
let n = String.length spec_str in
if n < 2 || spec_str.[0] <> '%' then
raise (Eval_error ("scan-spec: invalid spec " ^ spec_str));
let type_char = spec_str.[n - 1] in
let len = String.length str in
(* skip leading whitespace for non-%c/%s conversions *)
let i = ref 0 in
if type_char <> 'c' then
while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done;
let start = !i in
try
match type_char with
| 'd' | 'i' ->
let j = ref !i in
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done;
if !j > start && (str.[start] >= '0' && str.[start] <= '9'
|| (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then
let n_val = int_of_string (String.sub str start (!j - start)) in
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (Integer n_val);
Hashtbl.replace d "consumed" (Integer !j);
Dict d
else Nil
| 'x' | 'X' ->
let j = ref !i in
while !j < len &&
((str.[!j] >= '0' && str.[!j] <= '9') ||
(str.[!j] >= 'a' && str.[!j] <= 'f') ||
(str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done;
if !j > start then
let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (Integer n_val);
Hashtbl.replace d "consumed" (Integer !j);
Dict d
else Nil
| 'o' ->
let j = ref !i in
while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done;
if !j > start then
let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (Integer n_val);
Hashtbl.replace d "consumed" (Integer !j);
Dict d
else Nil
| 'f' | 'e' | 'g' ->
let j = ref !i in
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done;
if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin
incr j;
if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j;
while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done
end;
if !j > start then
let f_val = float_of_string (String.sub str start (!j - start)) in
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (Number f_val);
Hashtbl.replace d "consumed" (Integer !j);
Dict d
else Nil
| 's' ->
let j = ref !i in
while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done;
if !j > start then
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (String (String.sub str start (!j - start)));
Hashtbl.replace d "consumed" (Integer !j);
Dict d
else Nil
| 'c' ->
if !i < len then
let d = Hashtbl.create 2 in
Hashtbl.replace d "value" (Integer (Char.code str.[!i]));
Hashtbl.replace d "consumed" (Integer (!i + 1));
Dict d
else Nil
| _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char))
with
| Eval_error _ as e -> raise e
| _ -> Nil);
register "parse-int" (fun args ->
let parse_leading_int s =
let len = String.length s in
@@ -3091,6 +3268,640 @@ 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
let parse_open_mode mode =
match mode with
| "r" -> [Unix.O_RDONLY]
| "w" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
| "a" -> [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND]
| "r+" -> [Unix.O_RDWR]
| "w+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC]
| "a+" -> [Unix.O_RDWR; Unix.O_CREAT; Unix.O_APPEND]
| _ -> raise (Eval_error ("channel-open: invalid mode " ^ mode))
in
let chan_get name =
match Hashtbl.find_opt channel_table name with
| Some c -> c
| None -> raise (Eval_error ("channel: no such channel " ^ name))
in
register "channel-open" (fun args ->
match args with
| [String path; String mode] ->
(try
let fd = Unix.openfile path (parse_open_mode mode) 0o644 in
let id = !channel_next_id in
incr channel_next_id;
let name = Printf.sprintf "file%d" id in
Hashtbl.replace channel_table name (fd, mode, ref false, ref true);
String name
with Unix.Unix_error (e, _, _) -> raise (Eval_error ("channel-open: " ^ Unix.error_message e)))
| _ -> raise (Eval_error "channel-open: (path mode)"));
register "channel-close" (fun args ->
match args with
| [String name] ->
let (fd, _, _, _) = chan_get name in
(try Unix.close fd with _ -> ());
Hashtbl.remove channel_table name;
Nil
| _ -> raise (Eval_error "channel-close: (channel)"));
register "channel-read" (fun args ->
let (name, max_n) = match args with
| [String n] -> (n, -1)
| [String n; Integer m] -> (n, m)
| [String n; Number m] -> (n, int_of_float m)
| _ -> raise (Eval_error "channel-read: (channel ?n?)")
in
let (fd, _, eof, _) = chan_get name in
let chunk = 8192 in
let buf = Bytes.create chunk in
let buffer = Buffer.create chunk in
let total = ref 0 in
let stop = ref false in
while not !stop do
let want = if max_n < 0 then chunk else min chunk (max_n - !total) in
if want <= 0 then stop := true
else begin
try
let r = Unix.read fd buf 0 want in
if r = 0 then begin eof := true; stop := true end
else begin
Buffer.add_subbytes buffer buf 0 r;
total := !total + r
end
with
| Unix.Unix_error (Unix.EAGAIN, _, _)
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
end
done;
String (Buffer.contents buffer));
register "channel-read-line" (fun args ->
match args with
| [String name] ->
let (fd, _, eof, _) = chan_get name in
let buf = Buffer.create 80 in
let one = Bytes.create 1 in
let got_data = ref false in
let stop = ref false in
while not !stop do
try
let r = Unix.read fd one 0 1 in
if r = 0 then begin eof := true; stop := true end
else begin
got_data := true;
let c = Bytes.get one 0 in
if c = '\n' then stop := true
else Buffer.add_char buf c
end
with
| Unix.Unix_error (Unix.EAGAIN, _, _)
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> stop := true
done;
if !got_data then String (Buffer.contents buf) else Nil
| _ -> raise (Eval_error "channel-read-line: (channel)"));
register "channel-write" (fun args ->
match args with
| [String name; String s] ->
let (fd, _, _, _) = chan_get name in
let b = Bytes.of_string s in
let n = Bytes.length b in
let written = ref 0 in
while !written < n do
(try
let w = Unix.write fd b !written (n - !written) in
written := !written + w
with
| Unix.Unix_error (Unix.EAGAIN, _, _)
| Unix.Unix_error (Unix.EWOULDBLOCK, _, _) ->
(* short write — let caller retry *)
written := n)
done;
Nil
| _ -> raise (Eval_error "channel-write: (channel string)"));
register "channel-flush" (fun args ->
match args with
| [String name] -> let _ = chan_get name in Nil (* no userspace buffer *)
| _ -> raise (Eval_error "channel-flush: (channel)"));
register "channel-seek" (fun args ->
let (name, offset, whence) = match args with
| [String n; Integer o] -> (n, o, "start")
| [String n; Number o] -> (n, int_of_float o, "start")
| [String n; Integer o; String w] -> (n, o, w)
| [String n; Number o; String w] -> (n, int_of_float o, w)
| _ -> raise (Eval_error "channel-seek: (channel offset ?whence?)")
in
let (fd, _, eof, _) = chan_get name in
let cmd = match whence with
| "start" -> Unix.SEEK_SET
| "current" -> Unix.SEEK_CUR
| "end" -> Unix.SEEK_END
| _ -> raise (Eval_error ("channel-seek: invalid whence " ^ whence))
in
let _ = Unix.lseek fd offset cmd in
eof := false;
Nil);
register "channel-tell" (fun args ->
match args with
| [String name] ->
let (fd, _, _, _) = chan_get name in
Integer (Unix.lseek fd 0 Unix.SEEK_CUR)
| _ -> raise (Eval_error "channel-tell: (channel)"));
register "channel-eof?" (fun args ->
match args with
| [String name] ->
let (_, _, eof, _) = chan_get name in
Bool !eof
| _ -> raise (Eval_error "channel-eof?: (channel)"));
register "channel-blocking?" (fun args ->
match args with
| [String name] ->
let (_, _, _, blocking) = chan_get name in
Bool !blocking
| _ -> raise (Eval_error "channel-blocking?: (channel)"));
register "channel-set-blocking!" (fun args ->
match args with
| [String name; Bool b] ->
let (fd, _, _, blocking) = chan_get name in
blocking := b;
(try
if b then Unix.clear_nonblock fd
else Unix.set_nonblock fd
with _ -> ());
Nil
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
(* === Exec === run an external process; capture stdout *)
register "exec-process" (fun args ->
let items = match args with
| [List xs] | [ListRef { contents = xs }] -> xs
| _ -> raise (Eval_error "exec-process: (cmd-list)")
in
let argv = Array.of_list (List.map (function
| String s -> s
| v -> Sx_types.inspect v
) items) in
if Array.length argv = 0 then raise (Eval_error "exec: empty command");
let (out_r, out_w) = Unix.pipe () in
let (err_r, err_w) = Unix.pipe () in
let pid =
try Unix.create_process argv.(0) argv Unix.stdin out_w err_w
with Unix.Unix_error (e, _, _) ->
Unix.close out_r; Unix.close out_w;
Unix.close err_r; Unix.close err_w;
raise (Eval_error ("exec: " ^ Unix.error_message e))
in
Unix.close out_w;
Unix.close err_w;
let buf = Buffer.create 256 in
let errbuf = Buffer.create 64 in
let chunk = Bytes.create 4096 in
let read_all fd target =
try
let stop = ref false in
while not !stop do
let n = Unix.read fd chunk 0 (Bytes.length chunk) in
if n = 0 then stop := true
else Buffer.add_subbytes target chunk 0 n
done
with _ -> ()
in
read_all out_r buf;
read_all err_r errbuf;
Unix.close out_r;
Unix.close err_r;
let (_, status) = Unix.waitpid [] pid in
let exit_code = match status with
| Unix.WEXITED n -> n
| Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1
in
let s = Buffer.contents buf in
let trimmed =
if String.length s > 0 && s.[String.length s - 1] = '\n'
then String.sub s 0 (String.length s - 1) else s
in
if exit_code <> 0 then
raise (Eval_error ("exec: child exited " ^ string_of_int exit_code
^ (if Buffer.length errbuf > 0
then ": " ^ Buffer.contents errbuf
else "")))
else String trimmed);
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
stage; raises Eval_error if the last stage exits non-zero. *)
register "exec-pipeline" (fun args ->
let items = match args with
| [List xs] | [ListRef { contents = xs }] -> xs
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
in
let words = List.map (function
| String s -> s
| v -> Sx_types.inspect v
) items in
if words = [] then raise (Eval_error "exec: empty command");
let split_stages ws =
let rec loop acc cur = function
| [] -> List.rev (List.rev cur :: acc)
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
| w :: rest -> loop acc (w :: cur) rest
in
loop [] [] ws
in
let extract_redirs ws =
let in_path = ref None in
let out_path = ref None in
let out_append = ref false in
let err_path = ref None in
let merge_err = ref false in
let cleaned = ref [] in
let rec loop = function
| [] -> ()
| "<" :: p :: rest -> in_path := Some p; loop rest
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
| "2>@1" :: rest -> merge_err := true; loop rest
| "2>" :: p :: rest -> err_path := Some p; loop rest
| w :: rest -> cleaned := w :: !cleaned; loop rest
in
loop ws;
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
in
let stages = List.map extract_redirs (split_stages words) in
if stages = [] then raise (Eval_error "exec: no stages");
let n = List.length stages in
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
let (final_r, final_w) = Unix.pipe () in
let (errstash_r, errstash_w) = Unix.pipe () in
let pids = ref [] in
let close_safe fd = try Unix.close fd with _ -> () in
let open_in_redir = function
| None -> Unix.stdin
| Some path ->
(try Unix.openfile path [Unix.O_RDONLY] 0o644
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
in
let open_out_redir path append =
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
try Unix.openfile path flags 0o644
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
in
let stages_arr = Array.of_list stages in
(try
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
let argv = Array.of_list cleaned in
let stdin_fd =
if i = 0 then open_in_redir ip
else fst pipes.(i - 1)
in
let stdout_fd =
if i = n - 1 then
(match op with
| None -> final_w
| Some path -> open_out_redir path app)
else snd pipes.(i)
in
let stderr_fd =
if merge then stdout_fd
else (match ep with
| None -> if i = n - 1 then errstash_w else Unix.stderr
| Some path -> open_out_redir path false)
in
let pid =
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
in
pids := pid :: !pids;
if i > 0 then close_safe (fst pipes.(i - 1));
if i < n - 1 then close_safe (snd pipes.(i));
if i = 0 && ip <> None then close_safe stdin_fd;
if i = n - 1 && op <> None then close_safe stdout_fd;
if not merge && ep <> None then close_safe stderr_fd
) stages_arr
with e ->
close_safe final_r; close_safe final_w;
close_safe errstash_r; close_safe errstash_w;
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
raise e);
close_safe final_w;
close_safe errstash_w;
let buf = Buffer.create 256 in
let errbuf = Buffer.create 64 in
let chunk = Bytes.create 4096 in
let read_all fd target =
try
let stop = ref false in
while not !stop do
let r = Unix.read fd chunk 0 (Bytes.length chunk) in
if r = 0 then stop := true
else Buffer.add_subbytes target chunk 0 r
done
with _ -> ()
in
read_all final_r buf;
read_all errstash_r errbuf;
close_safe final_r;
close_safe errstash_r;
let exit_codes = List.rev_map (fun pid ->
let (_, st) = Unix.waitpid [] pid in
match st with
| Unix.WEXITED c -> c
| _ -> 1
) !pids in
let final_code = match List.rev exit_codes with
| [] -> 0
| last :: _ -> last
in
let s = Buffer.contents buf in
let trimmed =
if String.length s > 0 && s.[String.length s - 1] = '\n'
then String.sub s 0 (String.length s - 1) else s
in
if final_code <> 0 then
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
^ (if Buffer.length errbuf > 0
then ": " ^ Buffer.contents errbuf
else "")))
else String trimmed);
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
let resolve_inet_addr host =
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
else if host = "localhost" then Unix.inet_addr_loopback
else
try Unix.inet_addr_of_string host
with _ ->
try
let entry = Unix.gethostbyname host in
if Array.length entry.Unix.h_addr_list = 0 then
raise (Eval_error ("socket: cannot resolve " ^ host))
else entry.Unix.h_addr_list.(0)
with Not_found -> raise (Eval_error ("socket: cannot resolve " ^ host))
in
let port_of v = match v with
| Integer n -> n
| Number n -> int_of_float n
| _ -> raise (Eval_error "socket: port must be a number")
in
let alloc_chan_name () =
let id = !channel_next_id in
incr channel_next_id;
Printf.sprintf "sock%d" id
in
register "socket-connect" (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
(try Unix.connect sock addr
with Unix.Unix_error (e, _, _) ->
(try Unix.close sock with _ -> ());
raise (Eval_error ("socket-connect: " ^ Unix.error_message e)));
let name = alloc_chan_name () in
Hashtbl.replace channel_table name (sock, "rw", ref false, ref true);
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)
| [String h; port_v] -> (h, port_of port_v)
| _ -> raise (Eval_error "socket-server: (port) or (host port)")
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.setsockopt sock Unix.SO_REUSEADDR true;
(try Unix.bind sock addr
with Unix.Unix_error (e, _, _) ->
(try Unix.close sock with _ -> ());
raise (Eval_error ("socket-server: bind: " ^ Unix.error_message e)));
Unix.listen sock 8;
let name = alloc_chan_name () in
Hashtbl.replace channel_table name (sock, "server", ref false, ref true);
String name);
register "socket-accept" (fun args ->
match args with
| [String name] ->
let (sock, _, _, _) = chan_get name in
let (client_sock, client_addr) =
try Unix.accept sock
with Unix.Unix_error (e, _, _) ->
raise (Eval_error ("socket-accept: " ^ Unix.error_message e))
in
let (host_str, port) = match client_addr with
| Unix.ADDR_INET (addr, p) -> (Unix.string_of_inet_addr addr, p)
| Unix.ADDR_UNIX path -> (path, 0)
in
let client_name = alloc_chan_name () in
Hashtbl.replace channel_table client_name (client_sock, "rw", ref false, ref true);
let d = Hashtbl.create 3 in
Hashtbl.replace d "channel" (String client_name);
Hashtbl.replace d "host" (String host_str);
Hashtbl.replace d "port" (Integer port);
Dict d
| _ -> raise (Eval_error "socket-accept: (server-channel)"));
(* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
register "io-select-channels" (fun args ->
let to_ms v = match v with
| Integer n -> n
| Number n -> int_of_float n
| _ -> raise (Eval_error "io-select-channels: timeout must be a number")
in
let to_list v = match v with
| List xs | ListRef { contents = xs } -> xs
| Nil -> []
| _ -> raise (Eval_error "io-select-channels: expected list")
in
let chan_name_of v = match v with
| String s -> s
| _ -> raise (Eval_error "io-select-channels: channel must be a string")
in
let (read_list, write_list, timeout_ms) = match args with
| [r; w; t] -> (to_list r, to_list w, to_ms t)
| _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
in
let read_pairs = List.map (fun v ->
let name = chan_name_of v in
let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
let write_pairs = List.map (fun v ->
let name = chan_name_of v in
let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
let read_fds = List.map snd read_pairs in
let write_fds = List.map snd write_pairs in
let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
let (ready_r, ready_w, _) =
try Unix.select read_fds write_fds [] timeout
with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
in
let names_of pairs ready =
List.filter_map (fun (n, fd) ->
if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
) pairs
in
let d = Hashtbl.create 2 in
Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
Dict d);
(* === Clock === *)
register "clock-seconds" (fun args ->
match args with
@@ -3102,11 +3913,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
@@ -3114,14 +3922,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
@@ -3130,6 +3943,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
@@ -3137,8 +3951,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) === *)

File diff suppressed because it is too large Load Diff

View File

@@ -57,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
(eval "tcl-test-summary")
EPOCHS
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1)
OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1)
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
# Extract summary line from epoch 11 output

View File

@@ -124,7 +124,7 @@
"file0")
(ok "eof-returns-1"
(get (run "set ch [open /dev/null r]\neof $ch") :result)
(get (run "set ch [open /dev/null r]\nread $ch\neof $ch") :result)
"1")
(dict

View File

@@ -187,6 +187,496 @@
(env-extend (env-extend base "a" 3) "b" 7)
(quote (* a b))))
21)
; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking
(ok "channel-write-read"
(get
(run
"set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
:result)
"line one\nline two\n")
(ok "channel-gets-loop"
(get
(run
"set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out")
:result)
"apple banana cherry")
(ok "channel-seek-tell"
(get
(run
"set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"")
:result)
"6:world")
(ok "channel-eof-after-read"
(get
(run
"set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e")
:result)
"1")
(ok "channel-append-mode"
(get
(run
"set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
:result)
"first-second")
(ok "channel-seek-end"
(get
(run
"set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos")
:result)
"10")
(ok "channel-fconfigure-blocking"
(get
(run
"set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b")
:result)
"0")
; 33-37. Phase 5b event loop: after / vwait / fileevent / update
(ok "after-vwait-timer"
(get
(run
"after 30 {set ::done fired}\nvwait ::done\nset ::done")
:result)
"fired")
(ok "after-multiple-timers-update"
(get
(run
"set ::n 0\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nupdate\nset ::n")
:result)
"3")
(ok "fileevent-readable-fires"
(get
(run
"set f /tmp/tcl-phase5b-1.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nfileevent $c readable {set ::ready 1; fileevent $::ch readable {}}\nset ::ch $c\nvwait ::ready\nclose $c\nfile delete $f\nset ::ready")
:result)
"1")
(ok "fileevent-query-script"
(get
(run
"set f /tmp/tcl-phase5b-2.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfileevent $c readable {puts hello}\nset s [fileevent $c readable]\nclose $c\nfile delete $f\nreturn $s")
:result)
"puts hello")
(ok "after-cancel-via-vwait-timing"
(get
(run
"set ::counter 0\nafter 10 {incr ::counter}\nafter 50 {set ::done 1}\nvwait ::done\nset ::counter")
:result)
"1")
; 38-41. Phase 5c sockets: TCP client + server
(ok "socket-server-fires-callback"
(get
(run
"proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got")
:result)
"hit")
(ok "socket-client-server-roundtrip"
(get
(run
"proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received")
:result)
"ping")
(ok "socket-server-peer-host"
(get
(run
"proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer")
:result)
"127.0.0.1")
(ok "socket-multiple-connections"
(get
(run
"proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count")
:result)
"3")
; 42-49. Phase 5d file metadata + ops
(ok "file-isfile-true"
(get
(run
"set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r")
:result)
"1")
(ok "file-isfile-false-on-dir"
(get (run "file isfile /tmp") :result)
"0")
(ok "file-isdir-true"
(get (run "file isdir /tmp") :result)
"1")
(ok "file-size"
(get
(run
"set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s")
:result)
"5")
(ok "file-readable-true"
(get (run "file readable /tmp") :result)
"1")
(ok "file-readable-missing"
(get (run "file readable /no/such/path/here") :result)
"0")
(ok "file-mkdir-then-isdir"
(get
(run
"set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r")
:result)
"1")
(ok "file-copy-roundtrip"
(get
(run
"set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out")
:result)
"copydata")
(ok "file-rename-then-exists"
(get
(run
"set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r")
:result)
"0 1")
(ok "file-mtime-positive"
(get
(run
"set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}")
:result)
"1")
; 52-56. Phase 5e clock format options + clock scan
(ok "clock-format-utc"
(get
(run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1")
:result)
"1970-01-01 00:00:00")
(ok "clock-format-fmt-default"
(get
(run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1")
:result)
"2024-03-15")
(ok "clock-scan-roundtrip"
(get
(run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1")
:result)
"2024-06-15 12:00:00")
(ok "clock-scan-returns-int"
(get
(run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}")
:result)
"1")
(ok "clock-format-percent-pct"
(get
(run "clock format 0 -format {%Y%%%m} -gmt 1")
:result)
"1970%01")
; 57-59. Phase 5f socket -async (non-blocking connect)
(ok "socket-async-completes-writable"
(get
(run
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready")
:result)
"1")
(ok "socket-async-then-write"
(get
(run
"proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received")
:result)
"async-data")
(ok "socket-async-no-error"
(get
(run
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err")
:result)
"")
; 60-63. Phase 6a namespace :: prefix
(ok "ns-set-from-proc-reaches-global"
(get
(run
"proc f {x} { set ::g $x }\nf hello\nset ::g")
:result)
"hello")
(ok "ns-read-from-proc"
(get
(run
"set ::v 42\nproc f {} { return $::v }\nf")
:result)
"42")
(ok "ns-incr-via-prefix"
(get
(run
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
:result)
"7")
(ok "ns-different-from-local"
(get
(run
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
:result)
"inner")
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
(ok "lassign-three"
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
"a b c")
(ok "lassign-leftover"
(get (run "lassign {1 2 3 4 5} a b") :result)
"3 4 5")
(ok "lrepeat-basic"
(get (run "lrepeat 3 a") :result)
"a a a")
(ok "lrepeat-multi"
(get (run "lrepeat 2 x y") :result)
"x y x y")
(ok "lset-replaces"
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
"a b ZZ d")
(ok "lmap-square"
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
"1 4 9 16")
; 70-72. Phase 6c dict additions (lappend, remove, filter)
(ok "dict-lappend-extends"
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
"tags {a b c d}")
(ok "dict-remove"
(get (run "dict remove {a 1 b 2 c 3} b") :result)
"a 1 c 3")
(ok "dict-filter-key"
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
"alpha 1")
; 73-79. Phase 6d format and scan
(ok "format-int-padded"
(get (run "format {%05d} 42") :result)
"00042")
(ok "format-float-precision"
(get (run "format {%.2f} 3.14159") :result)
"3.14")
(ok "format-hex"
(get (run "format {%x} 255") :result)
"ff")
(ok "format-char"
(get (run "format {%c} 65") :result)
"A")
(ok "format-string-left"
(get (run "format {%-5s|} hi") :result)
"hi |")
(ok "scan-two-ints"
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
"12 34")
(ok "scan-count"
(get (run "scan {hello 42} {%s %d}") :result)
"hello 42")
; 80-82. Phase 6e exec
(ok "exec-echo"
(get (run "exec echo hello world") :result)
"hello world")
(ok "exec-printf-no-newline"
(get (run "exec /bin/printf x") :result)
"x")
(ok "exec-with-args"
(get (run "exec /bin/echo -n test") :result)
"test")
; 83-87. Phase 7a try/trap with varlist
(ok "try-trap-prefix-match"
(get
(run
"try {throw {ARITH DIVZERO} divide-by-zero} trap {ARITH} {res} {set caught $res}")
:result)
"divide-by-zero")
(ok "try-trap-full-pattern"
(get
(run
"try {throw {FOO BAR} bad} trap {FOO BAR} {res} {return matched-foo-bar}")
:result)
"matched-foo-bar")
(ok "try-on-error-opts"
(get
(run
"try {error oops} on error {res opts} {dict get $opts -code}")
:result)
"1")
(ok "try-trap-no-match-falls-through"
(get
(run
"set caught notrun\ncatch {try {throw {NOPE} bad} trap {OTHER} {r} {set caught matched}}\nset caught")
:result)
"notrun")
(ok "try-trap-then-on-error"
(get
(run
"try {error generic} trap {SPECIFIC} {r} {return trap-fired} on error {r} {return on-error-fired}")
:result)
"on-error-fired")
; 88-92. Phase 7b exec pipelines + redirection
(ok "exec-pipeline-tr"
(get (run "exec echo hello world | tr a-z A-Z") :result)
"HELLO WORLD")
(ok "exec-pipeline-wc"
(get (run "exec /bin/echo abc | wc -c") :result)
"4")
(ok "exec-redirect-stdout"
(get
(run
"set f /tmp/tcl-7b-out.txt\nexec echo hello > $f\nset r [exec cat $f]\nfile delete $f\nreturn $r")
:result)
"hello")
(ok "exec-redirect-stdin"
(get
(run
"set f /tmp/tcl-7b-in.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset r [exec cat < $f]\nfile delete $f\nreturn $r")
:result)
"hi")
(ok "exec-pipeline-three-stages"
(get (run "exec echo {alpha beta gamma} | tr { } \\n | wc -l") :result)
"3")
; 93-99. Phase 7c string command audit
(ok "string-equal"
(get (run "string equal hello hello") :result)
"1")
(ok "string-equal-nocase"
(get (run "string equal -nocase HELLO hello") :result)
"1")
(ok "string-totitle"
(get (run "string totitle hello") :result)
"Hello")
(ok "string-reverse"
(get (run "string reverse hello") :result)
"olleh")
(ok "string-replace"
(get (run "string replace hello 1 3 ZZZ") :result)
"hZZZo")
(ok "string-is-xdigit-yes"
(get (run "string is xdigit ff00aa") :result)
"1")
(ok "string-is-true-yes"
(get (run "string is true yes") :result)
"1")
; 100-105. Phase 7e regexp anchoring/boundary audit
(ok "regexp-anchor-start"
(get (run "regexp {^hello} hello-world") :result)
"1")
(ok "regexp-anchor-end"
(get (run "regexp {world$} hello-world") :result)
"1")
(ok "regexp-word-boundary"
(get (run "regexp {\\bword\\b} \"the word here\"") :result)
"1")
(ok "regexp-nocase"
(get (run "regexp -nocase {HELLO} hello") :result)
"1")
(ok "regexp-capture-var"
(get (run "regexp {[0-9]+} abc123def captured\nset captured") :result)
"123")
(ok "regsub-all"
(get (run "regsub -all {[0-9]+} a1b22c333 X") :result)
"aXbXcX")
; 106-110. Phase 7d TclOO basics
(ok "oo-class-method"
(get
(run
"oo::class create C {\nmethod get {} { return 42 }\n}\nset c [C new]\n$c get")
:result)
"42")
(ok "oo-constructor"
(get
(run
"oo::class create G {\nconstructor {n} { set ::gname $n }\nmethod hello {} { return [string cat \"hi \" $::gname] }\n}\nset g [G new World]\n$g hello")
:result)
"hi World")
(ok "oo-inheritance-overridden"
(get
(run
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Dog {\nsuperclass Animal\nmethod sound {} { return woof }\n}\nset d [Dog new]\n$d sound")
:result)
"woof")
(ok "oo-inheritance-inherited"
(get
(run
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Cat {\nsuperclass Animal\n}\nset c [Cat new]\n$c sound")
:result)
"generic")
(ok "oo-multiple-instances"
(get
(run
"oo::class create N {\nconstructor {x} { set ::nval $x }\nmethod get {} { return $::nval }\n}\nset a [N new 1]\nset b [N new 99]\n$b get")
:result)
"99")
(dict
"passed"
tcl-idiom-pass

View File

@@ -167,7 +167,9 @@
(begin
(when (= (cur) "}") (advance! 1))
{:type "var" :name name}))))))
((tcl-ident-start? (cur))
((or
(tcl-ident-start? (cur))
(and (= (cur) ":") (= (char-at 1) ":")))
(let ((start pos))
(begin
(scan-ns-name!)