Compare commits

...

9 Commits

Author SHA1 Message Date
2defa5e739 GUEST-plan: claim step 6 — match.sx
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 56s
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 18:29:33 +00:00
64157e9e81 Merge remote-tracking branch 'origin/loops/tcl' into architecture 2026-05-07 18:29:26 +00:00
e0d447e2ce plans: tick Phase 5d/5e/5f — file ops, clock locale+scan, socket -async — 376/376
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-07 18:29:20 +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
6915730029 GUEST-plan: log step 5 partial — kit + tests, real consumers deferred
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 17:35:59 +00:00
a774cd26c1 GUEST: step 5 — lib/guest/ast.sx canonical AST shapes (kit + tests)
Defines the 10 canonical node kinds called out in the brief — literal,
var, app, lambda, let, letrec, if, match-clause, module, import — plus
predicates, ast-kind dispatch, and per-field accessors. Each node is a
tagged keyword-headed list: (:literal V), (:var N), (:app FN ARGS), …

Also lib/guest/tests/ast.sx — 33 tests exercising every constructor +
predicate + accessor, runnable via (gast-tests-run!) which returns the
{:passed :failed :total} dict the shared conformance driver expects.

PARTIAL — pending real consumers. The brief calls Step 5 "Optional —
guests may keep their own AST" and forcing lua/prolog to switch their
internal AST shape risks regressing 775 passing tests for tooling that
nothing yet calls. Both internal ASTs are untouched; lua still 185/185,
prolog still 590/590. Datalog-on-sx (in flight, see plans/datalog-on-sx.md)
will be the natural first real consumer; lua/prolog converters can land
when a cross-language tool wants them.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 17:35:49 +00:00
69a0886214 GUEST-plan: claim step 5 — ast.sx
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 17:22:43 +00:00
5f27125f01 GUEST-plan: log step 4 done
Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 17:17:27 +00:00
da27958d67 GUEST: step 4 — lib/guest/pratt.sx operator-table format + lookup
Extracted the data-half of Pratt-style precedence parsing: the operator
table format and lookup. The climbing loop stays per-language because
the two canaries use opposite conventions (lua: higher prec = tighter;
prolog: lower prec = tighter, with xfx/xfy/yfx assoc tags) — forcing
one shared loop adds callback indirection that obscures more than it
shares. The brief's literal ask is "Grammar is a dict, not hardcoded
cond" and that's what gets shared.

Entry shape: (NAME PREC ASSOC). Three accessors: pratt-op-name /
pratt-op-prec / pratt-op-assoc. One traversal: pratt-op-lookup.

Ported lua/parser.sx — replaced 18-clause cond and the
lua-binop-right? hardcoded `or` with a 15-entry lua-op-table, now
queried via pratt-op-lookup. Ported prolog/parser.sx — pl-op-find
(linear walk reimpl) deleted; pl-op-lookup wraps pratt-op-lookup;
pl-token-op simplified to return the entry directly.

Verification:
- lua/test.sh: 185/185 = baseline.
- prolog/conformance.sh: 590/590 = baseline (timestamp-only diff).

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-07 17:17:17 +00:00
15 changed files with 777 additions and 90 deletions

View File

@@ -3124,6 +3124,108 @@ let () =
| [String pat] -> List (List.map (fun s -> String s) (glob_paths pat)) | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
| _ -> raise (Eval_error "file-glob: (pattern)")); | _ -> 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) === *) (* === 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_table : (string, Unix.file_descr * string * bool ref * bool ref) Hashtbl.t = Hashtbl.create 16 in
let channel_next_id = ref 0 in let channel_next_id = ref 0 in
@@ -3337,6 +3439,43 @@ let () =
String name String name
| _ -> raise (Eval_error "socket-connect: (host port)")); | _ -> 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 -> register "socket-server" (fun args ->
let (host, port) = match args with let (host, port) = match args with
| [port_v] -> ("", port_of port_v) | [port_v] -> ("", port_of port_v)
@@ -3432,11 +3571,8 @@ let () =
| [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0)) | [] -> Integer (int_of_float (Unix.gettimeofday () *. 1000.0))
| _ -> raise (Eval_error "clock-milliseconds: no args")); | _ -> raise (Eval_error "clock-milliseconds: no args"));
register "clock-format" (fun args -> let format_tm tm tz_label =
match args with fun fmt ->
| [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 buf = Buffer.create 32 in let buf = Buffer.create 32 in
let n = String.length fmt in let n = String.length fmt in
let i = ref 0 in let i = ref 0 in
@@ -3444,14 +3580,19 @@ let () =
if fmt.[!i] = '%' && !i + 1 < n then begin if fmt.[!i] = '%' && !i + 1 < n then begin
(match fmt.[!i + 1] with (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 "%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)) | '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) | 'd' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_mday)
| 'e' -> Buffer.add_string buf (Printf.sprintf "%2d" 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) | '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) | 'M' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_min)
| 'S' -> Buffer.add_string buf (Printf.sprintf "%02d" tm.Unix.tm_sec) | '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)) | '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 | 'a' -> let days = [|"Sun";"Mon";"Tue";"Wed";"Thu";"Fri";"Sat"|] in
Buffer.add_string buf days.(tm.Unix.tm_wday) Buffer.add_string buf days.(tm.Unix.tm_wday)
| 'A' -> let days = [|"Sunday";"Monday";"Tuesday";"Wednesday";"Thursday";"Friday";"Saturday"|] in | '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) 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 | '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_string buf mons.(tm.Unix.tm_mon)
| '%' -> Buffer.add_char buf '%'
| c -> Buffer.add_char buf '%'; Buffer.add_char buf c); | c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
i := !i + 2 i := !i + 2
end else begin end else begin
@@ -3467,8 +3609,100 @@ let () =
incr i incr i
end end
done; done;
String (Buffer.contents buf) Buffer.contents buf
| _ -> raise (Eval_error "clock-format: (seconds [format])")); 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) === *) (* === Env-as-value (Phase 4) === *)

92
lib/guest/ast.sx Normal file
View File

@@ -0,0 +1,92 @@
;; lib/guest/ast.sx — canonical AST node shapes.
;;
;; A guest's parser may emit its own AST in whatever shape is convenient
;; for that language's evaluator/transpiler. This file gives a SHARED
;; canonical shape that cross-language tools (formatters, highlighters,
;; debuggers) can target without per-language adapters.
;;
;; Each canonical node is a tagged list: (KIND ...payload).
;;
;; Constructors (return a canonical node):
;;
;; (ast-literal VALUE) — number / string / bool / nil
;; (ast-var NAME) — identifier reference
;; (ast-app FN ARGS) — function application
;; (ast-lambda PARAMS BODY) — anonymous function
;; (ast-let BINDINGS BODY) — local bindings
;; (ast-letrec BINDINGS BODY) — recursive local bindings
;; (ast-if TEST THEN ELSE) — conditional
;; (ast-match-clause PATTERN BODY) — one match arm
;; (ast-module NAME BODY) — module declaration
;; (ast-import NAME) — import directive
;;
;; Predicates: (ast-literal? X), (ast-var? X), …
;; Generic: (ast? X) — any canonical node
;; (ast-kind X) — :literal / :var / :app / …
;;
;; Accessors (one per payload field):
;; (ast-literal-value N)
;; (ast-var-name N)
;; (ast-app-fn N) (ast-app-args N)
;; (ast-lambda-params N) (ast-lambda-body N)
;; (ast-let-bindings N) (ast-let-body N)
;; (ast-letrec-bindings N) (ast-letrec-body N)
;; (ast-if-test N) (ast-if-then N) (ast-if-else N)
;; (ast-match-clause-pattern N)
;; (ast-match-clause-body N)
;; (ast-module-name N) (ast-module-body N)
;; (ast-import-name N)
(define ast-literal (fn (v) (list :literal v)))
(define ast-var (fn (n) (list :var n)))
(define ast-app (fn (f args) (list :app f args)))
(define ast-lambda (fn (ps body) (list :lambda ps body)))
(define ast-let (fn (bs body) (list :let bs body)))
(define ast-letrec (fn (bs body) (list :letrec bs body)))
(define ast-if (fn (t th el) (list :if t th el)))
(define ast-match-clause (fn (p body) (list :match-clause p body)))
(define ast-module (fn (n body) (list :module n body)))
(define ast-import (fn (n) (list :import n)))
(define ast-kind (fn (x) (if (and (list? x) (not (empty? x))) (first x) nil)))
(define
ast?
(fn (x)
(and (list? x)
(not (empty? x))
(let ((k (first x)))
(or (= k :literal) (= k :var) (= k :app)
(= k :lambda) (= k :let) (= k :letrec)
(= k :if) (= k :match-clause)
(= k :module) (= k :import))))))
(define ast-literal? (fn (x) (and (ast? x) (= (first x) :literal))))
(define ast-var? (fn (x) (and (ast? x) (= (first x) :var))))
(define ast-app? (fn (x) (and (ast? x) (= (first x) :app))))
(define ast-lambda? (fn (x) (and (ast? x) (= (first x) :lambda))))
(define ast-let? (fn (x) (and (ast? x) (= (first x) :let))))
(define ast-letrec? (fn (x) (and (ast? x) (= (first x) :letrec))))
(define ast-if? (fn (x) (and (ast? x) (= (first x) :if))))
(define ast-match-clause? (fn (x) (and (ast? x) (= (first x) :match-clause))))
(define ast-module? (fn (x) (and (ast? x) (= (first x) :module))))
(define ast-import? (fn (x) (and (ast? x) (= (first x) :import))))
(define ast-literal-value (fn (n) (nth n 1)))
(define ast-var-name (fn (n) (nth n 1)))
(define ast-app-fn (fn (n) (nth n 1)))
(define ast-app-args (fn (n) (nth n 2)))
(define ast-lambda-params (fn (n) (nth n 1)))
(define ast-lambda-body (fn (n) (nth n 2)))
(define ast-let-bindings (fn (n) (nth n 1)))
(define ast-let-body (fn (n) (nth n 2)))
(define ast-letrec-bindings (fn (n) (nth n 1)))
(define ast-letrec-body (fn (n) (nth n 2)))
(define ast-if-test (fn (n) (nth n 1)))
(define ast-if-then (fn (n) (nth n 2)))
(define ast-if-else (fn (n) (nth n 3)))
(define ast-match-clause-pattern (fn (n) (nth n 1)))
(define ast-match-clause-body (fn (n) (nth n 2)))
(define ast-module-name (fn (n) (nth n 1)))
(define ast-module-body (fn (n) (nth n 2)))
(define ast-import-name (fn (n) (nth n 1)))

28
lib/guest/pratt.sx Normal file
View File

@@ -0,0 +1,28 @@
;; lib/guest/pratt.sx — operator-table format + lookup for Pratt-style
;; precedence climbing.
;;
;; The climbing loop stays per-language because the two canaries use
;; opposite conventions (Lua: higher prec = tighter; Prolog: lower prec =
;; tighter, with xfx/xfy/yfx assoc tags). Forcing a single loop adds
;; callback indirection that obscures more than it shares.
;;
;; What IS shared and gets extracted: the operator-table format and lookup.
;; "Grammar is a dict, not hardcoded cond."
;;
;; Entry shape: (NAME PREC ASSOC).
;; NAME — string, the operator's source token.
;; PREC — integer, in the host's own convention.
;; ASSOC — :left | :right | :none for languages with traditional
;; associativity, or "xfx" / "xfy" / "yfx" for Prolog-style.
(define
pratt-op-lookup
(fn (table name)
(cond
((empty? table) nil)
((= (first (first table)) name) (first table))
(:else (pratt-op-lookup (rest table) name)))))
(define pratt-op-name (fn (entry) (first entry)))
(define pratt-op-prec (fn (entry) (nth entry 1)))
(define pratt-op-assoc (fn (entry) (nth entry 2)))

63
lib/guest/tests/ast.sx Normal file
View File

@@ -0,0 +1,63 @@
;; lib/guest/tests/ast.sx — exercises every constructor / predicate /
;; accessor in lib/guest/ast.sx so future ports have a stable contract
;; to point at.
(define gast-test-pass 0)
(define gast-test-fail 0)
(define gast-test-fails (list))
(define
gast-test
(fn (name actual expected)
(if (= actual expected)
(set! gast-test-pass (+ gast-test-pass 1))
(begin
(set! gast-test-fail (+ gast-test-fail 1))
(append! gast-test-fails {:name name :expected expected :actual actual})))))
;; Constructors round-trip.
(gast-test "literal-int" (ast-literal-value (ast-literal 42)) 42)
(gast-test "literal-str" (ast-literal-value (ast-literal "hi")) "hi")
(gast-test "literal-bool" (ast-literal-value (ast-literal true)) true)
(gast-test "var-name" (ast-var-name (ast-var "x")) "x")
(gast-test "app-fn" (ast-app-fn (ast-app (ast-var "f") (list (ast-literal 1)))) (ast-var "f"))
(gast-test "app-args-len" (len (ast-app-args (ast-app (ast-var "f") (list (ast-literal 1))))) 1)
(gast-test "lambda-params" (ast-lambda-params (ast-lambda (list "x" "y") (ast-var "x"))) (list "x" "y"))
(gast-test "lambda-body" (ast-lambda-body (ast-lambda (list "x") (ast-var "x"))) (ast-var "x"))
(gast-test "let-bindings" (len (ast-let-bindings (ast-let (list {:name "x" :value (ast-literal 1)}) (ast-var "x")))) 1)
(gast-test "letrec-body" (ast-letrec-body (ast-letrec (list) (ast-literal 0))) (ast-literal 0))
(gast-test "if-test" (ast-if-test (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal true))
(gast-test "if-then" (ast-if-then (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 1))
(gast-test "if-else" (ast-if-else (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) (ast-literal 0))
(gast-test "match-pattern" (ast-match-clause-pattern (ast-match-clause "P" (ast-literal 1))) "P")
(gast-test "match-body" (ast-match-clause-body (ast-match-clause "P" (ast-literal 1))) (ast-literal 1))
(gast-test "module-name" (ast-module-name (ast-module "m" (list))) "m")
(gast-test "import-name" (ast-import-name (ast-import "lib/foo")) "lib/foo")
;; Predicates fire only on matching kinds.
(gast-test "is-literal" (ast-literal? (ast-literal 1)) true)
(gast-test "not-literal" (ast-literal? (ast-var "x")) false)
(gast-test "is-var" (ast-var? (ast-var "x")) true)
(gast-test "is-app" (ast-app? (ast-app (ast-var "f") (list))) true)
(gast-test "is-lambda" (ast-lambda? (ast-lambda (list) (ast-literal 0))) true)
(gast-test "is-let" (ast-let? (ast-let (list) (ast-literal 0))) true)
(gast-test "is-letrec" (ast-letrec? (ast-letrec (list) (ast-literal 0))) true)
(gast-test "is-if" (ast-if? (ast-if (ast-literal true) (ast-literal 1) (ast-literal 0))) true)
(gast-test "is-match" (ast-match-clause? (ast-match-clause "P" (ast-literal 1))) true)
(gast-test "is-module" (ast-module? (ast-module "m" (list))) true)
(gast-test "is-import" (ast-import? (ast-import "x")) true)
;; ast? recognises any canonical node.
(gast-test "ast?-literal" (ast? (ast-literal 0)) true)
(gast-test "ast?-foreign" (ast? (list "lua-num" 0)) false)
(gast-test "ast?-non-list" (ast? 42) false)
;; ast-kind dispatch.
(gast-test "kind-literal" (ast-kind (ast-literal 0)) :literal)
(gast-test "kind-import" (ast-kind (ast-import "x")) :import)
(define gast-tests-run!
(fn ()
{:passed gast-test-pass
:failed gast-test-fail
:total (+ gast-test-pass gast-test-fail)}))

View File

@@ -3,28 +3,33 @@
(define lua-tok-value (fn (t) (if (= t nil) nil (get t :value)))) (define lua-tok-value (fn (t) (if (= t nil) nil (get t :value))))
(define (define
lua-binop-prec lua-op-table
(fn (list
(op) (list "or" 1 :left)
(cond (list "and" 2 :left)
((= op "or") 1) (list "<" 3 :left)
((= op "and") 2) (list ">" 3 :left)
((= op "<") 3) (list "<=" 3 :left)
((= op ">") 3) (list ">=" 3 :left)
((= op "<=") 3) (list "==" 3 :left)
((= op ">=") 3) (list "~=" 3 :left)
((= op "==") 3) (list ".." 5 :right)
((= op "~=") 3) (list "+" 6 :left)
((= op "..") 5) (list "-" 6 :left)
((= op "+") 6) (list "*" 7 :left)
((= op "-") 6) (list "/" 7 :left)
((= op "*") 7) (list "%" 7 :left)
((= op "/") 7) (list "^" 10 :right)))
((= op "%") 7)
((= op "^") 10)
(else 0))))
(define lua-binop-right? (fn (op) (or (= op "..") (= op "^")))) (define lua-binop-prec
(fn (op)
(let ((entry (pratt-op-lookup lua-op-table op)))
(if (= entry nil) 0 (pratt-op-prec entry)))))
(define lua-binop-right?
(fn (op)
(let ((entry (pratt-op-lookup lua-op-table op)))
(and (not (= entry nil)) (= (pratt-op-assoc entry) :right)))))
(define (define
lua-parse lua-parse

View File

@@ -30,6 +30,7 @@ cat > "$TMPFILE" << 'EPOCHS'
(epoch 1) (epoch 1)
(load "lib/guest/lex.sx") (load "lib/guest/lex.sx")
(load "lib/guest/prefix.sx") (load "lib/guest/prefix.sx")
(load "lib/guest/pratt.sx")
(load "lib/lua/tokenizer.sx") (load "lib/lua/tokenizer.sx")
(epoch 2) (epoch 2)
(load "lib/lua/parser.sx") (load "lib/lua/parser.sx")

View File

@@ -4,6 +4,7 @@ LANG_NAME=prolog
MODE=dict MODE=dict
PRELOADS=( PRELOADS=(
lib/guest/pratt.sx
lib/prolog/tokenizer.sx lib/prolog/tokenizer.sx
lib/prolog/parser.sx lib/prolog/parser.sx
lib/prolog/runtime.sx lib/prolog/runtime.sx

View File

@@ -104,18 +104,9 @@
(list ":-" 1200 "xfx") (list ":-" 1200 "xfx")
(list "mod" 400 "yfx"))) (list "mod" 400 "yfx")))
(define (define pl-op-lookup (fn (name) (pratt-op-lookup pl-op-table name)))
pl-op-find
(fn
(name table)
(cond
((empty? table) nil)
((= (first (first table)) name) (rest (first table)))
(true (pl-op-find name (rest table))))))
(define pl-op-lookup (fn (name) (pl-op-find name pl-op-table))) ;; Token → entry (name prec type) for known infix ops, else nil.
;; Token → (name prec type) for known infix ops, else nil.
(define (define
pl-token-op pl-token-op
(fn (fn
@@ -123,14 +114,8 @@
(let (let
((ty (get t :type)) (vv (get t :value))) ((ty (get t :type)) (vv (get t :value)))
(cond (cond
((and (= ty "punct") (= vv ",")) ((and (= ty "punct") (= vv ",")) (pl-op-lookup ","))
(let ((or (= ty "atom") (= ty "op")) (pl-op-lookup vv))
((info (pl-op-lookup ",")))
(if (nil? info) nil (cons "," info))))
((or (= ty "atom") (= ty "op"))
(let
((info (pl-op-lookup vv)))
(if (nil? info) nil (cons vv info))))
(true nil))))) (true nil)))))
;; ── Term parser ───────────────────────────────────────────────────── ;; ── Term parser ─────────────────────────────────────────────────────

View File

@@ -3,5 +3,5 @@
"total_failed": 0, "total_failed": 0,
"total": 590, "total": 590,
"suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0},"compiler":{"passed":17,"total":17,"failed":0},"cross_validate":{"passed":17,"total":17,"failed":0},"integration":{"passed":20,"total":20,"failed":0},"hs_bridge":{"passed":19,"total":19,"failed":0}}, "suites": {"parse":{"passed":25,"total":25,"failed":0},"unify":{"passed":47,"total":47,"failed":0},"clausedb":{"passed":14,"total":14,"failed":0},"solve":{"passed":62,"total":62,"failed":0},"operators":{"passed":19,"total":19,"failed":0},"dynamic":{"passed":11,"total":11,"failed":0},"findall":{"passed":11,"total":11,"failed":0},"term_inspect":{"passed":14,"total":14,"failed":0},"append":{"passed":6,"total":6,"failed":0},"reverse":{"passed":6,"total":6,"failed":0},"member":{"passed":7,"total":7,"failed":0},"nqueens":{"passed":6,"total":6,"failed":0},"family":{"passed":10,"total":10,"failed":0},"atoms":{"passed":34,"total":34,"failed":0},"query_api":{"passed":16,"total":16,"failed":0},"iso_predicates":{"passed":29,"total":29,"failed":0},"meta_predicates":{"passed":25,"total":25,"failed":0},"list_predicates":{"passed":33,"total":33,"failed":0},"meta_call":{"passed":15,"total":15,"failed":0},"set_predicates":{"passed":15,"total":15,"failed":0},"char_predicates":{"passed":27,"total":27,"failed":0},"io_predicates":{"passed":24,"total":24,"failed":0},"assert_rules":{"passed":15,"total":15,"failed":0},"string_agg":{"passed":25,"total":25,"failed":0},"advanced":{"passed":21,"total":21,"failed":0},"compiler":{"passed":17,"total":17,"failed":0},"cross_validate":{"passed":17,"total":17,"failed":0},"integration":{"passed":20,"total":20,"failed":0},"hs_bridge":{"passed":19,"total":19,"failed":0}},
"generated": "2026-05-06T22:23:38+00:00" "generated": "2026-05-07T17:35:23+00:00"
} }

View File

@@ -1,7 +1,7 @@
# Prolog scoreboard # Prolog scoreboard
**590 / 590 passing** (0 failure(s)). **590 / 590 passing** (0 failure(s)).
Generated 2026-05-06T22:23:38+00:00. Generated 2026-05-07T17:35:23+00:00.
| Suite | Passed | Total | Status | | Suite | Passed | Total | Status |
|-------|--------|-------|--------| |-------|--------|-------|--------|

View File

@@ -292,13 +292,15 @@
(> (len result-stack) caller-stack-len) (> (len result-stack) caller-stack-len)
(nth result-stack caller-stack-len) (nth result-stack caller-stack-len)
(get interp :frame)))) (get interp :frame))))
(assoc interp ; Forward result-interp as base so state changes inside
; the proc (e.g. :fileevents, :timers, :procs) propagate;
; restore caller's frame/stack/result/output/code.
(assoc result-interp
:frame updated-caller :frame updated-caller
:frame-stack updated-below :frame-stack updated-below
:result result-val :result result-val
:output (str caller-output proc-output) :output (str caller-output proc-output)
:code (if (= code 2) 0 code) :code (if (= code 2) 0 code))))))))))))))
:commands (get result-interp :commands))))))))))))))
(define (define
tcl-eval-cmd tcl-eval-cmd
@@ -2887,12 +2889,54 @@
((equal? sub "seconds") (assoc interp :result (str (clock-seconds)))) ((equal? sub "seconds") (assoc interp :result (str (clock-seconds))))
((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds)))) ((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds))))
((equal? sub "format") ((equal? sub "format")
(assoc interp :result (clock-format ; clock format $secs ?-format $fmt? ?-timezone $tz? ?-gmt 0|1?
(floor (parse-int (first rest-args))) (let
(if (> (len rest-args) 1) (nth rest-args (- (len rest-args) 1)) "%a %b %e %H:%M:%S %Z %Y")))) ((t (floor (parse-int (first rest-args))))
((equal? sub "scan") (assoc interp :result "0")) (opts (rest rest-args)))
(let
((fmt (tcl-clock-opt opts "-format" "%a %b %e %H:%M:%S %Z %Y"))
(tz (tcl-clock-tz opts)))
(assoc interp :result (clock-format t fmt tz)))))
((equal? sub "scan")
; clock scan $str ?-format $fmt? ?-timezone $tz? ?-gmt 0|1?
(let
((s (first rest-args)) (opts (rest rest-args)))
(let
((fmt (tcl-clock-opt opts "-format" "%Y-%m-%d %H:%M:%S"))
(tz (tcl-clock-tz opts)))
(assoc interp :result (str (clock-scan s fmt tz))))))
(else (error (str "clock: unknown subcommand \"" sub "\"")))))))) (else (error (str "clock: unknown subcommand \"" sub "\""))))))))
; Helper: extract a -flag $val pair from clock args.
(define
tcl-clock-opt
(fn
(opts flag default)
(cond
((< (len opts) 2) default)
((equal? (first opts) flag) (nth opts 1))
(else (tcl-clock-opt (rest (rest opts)) flag default)))))
; Helper: derive tz string from clock opts (-timezone or -gmt).
(define
tcl-clock-tz
(fn
(opts)
(let
((tz-explicit (tcl-clock-opt opts "-timezone" nil))
(gmt-flag (tcl-clock-opt opts "-gmt" nil)))
(cond
((not (nil? tz-explicit))
(cond
((equal? tz-explicit ":UTC") "utc")
((equal? tz-explicit "UTC") "utc")
((equal? tz-explicit "GMT") "utc")
(else "local")))
((equal? gmt-flag "1") "utc")
((equal? gmt-flag "true") "utc")
((not (nil? gmt-flag)) "local")
(else "utc")))))
(define (define
tcl-cmd-open tcl-cmd-open
(fn (fn
@@ -2973,26 +3017,31 @@
(interp args) (interp args)
(let (let
((chan (first args)) (rest-args (rest args))) ((chan (first args)) (rest-args (rest args)))
(if (cond
(= 0 (len rest-args)) ((= 0 (len rest-args))
(assoc (assoc
interp interp
:result (str "-blocking " (if (channel-blocking? chan) "1" "0"))) :result (str "-blocking " (if (channel-blocking? chan) "1" "0"))))
(if ((and
(and (= 2 (len rest-args))
(= 2 (len rest-args)) (equal? (first rest-args) "-blocking"))
(equal? (first rest-args) "-blocking"))
(let (let
((b (nth rest-args 1))) ((b (nth rest-args 1)))
(let (let
((_ (channel-set-blocking! chan (not (or (equal? b "0") (equal? b "false")))))) ((_
(assoc interp :result ""))) (channel-set-blocking!
(if chan
(and (not (or (equal? b "0") (equal? b "false"))))))
(= 1 (len rest-args)) (assoc interp :result ""))))
(equal? (first rest-args) "-blocking")) ((and
(assoc interp :result (if (channel-blocking? chan) "1" "0")) (= 1 (len rest-args))
(assoc interp :result ""))))))) (equal? (first rest-args) "-blocking"))
(assoc interp :result (if (channel-blocking? chan) "1" "0")))
((and
(= 1 (len rest-args))
(equal? (first rest-args) "-error"))
(assoc interp :result (channel-async-error chan)))
(else (assoc interp :result ""))))))
; ============================================================ ; ============================================================
@@ -3253,6 +3302,13 @@
(assoc (assoc
(tcl-fileevent-set interp server-chan "readable" handler) (tcl-fileevent-set interp server-chan "readable" handler)
:result server-chan)))))) :result server-chan))))))
((equal? (first args) "-async")
(if
(< (len args) 3)
(error "socket: usage: socket -async host port")
(let
((host (nth args 1)) (port (parse-int (nth args 2))))
(assoc interp :result (socket-connect-async host port)))))
((= 2 (len args)) ((= 2 (len args))
(let (let
((host (first args)) (port (parse-int (nth args 1)))) ((host (first args)) (port (parse-int (nth args 1))))
@@ -3609,16 +3665,52 @@
(equal? dot-idx "-1") (equal? dot-idx "-1")
nm nm
(substring nm 0 (parse-int dot-idx))))))) (substring nm 0 (parse-int dot-idx)))))))
((equal? sub "isfile") (assoc interp :result "0")) ((equal? sub "isfile")
((equal? sub "isdir") (assoc interp :result "0")) (assoc interp :result (if (file-isfile? (first rest-args)) "1" "0")))
((equal? sub "isdirectory") (assoc interp :result "0")) ((equal? sub "isdir")
((equal? sub "readable") (assoc interp :result "0")) (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0")))
((equal? sub "writable") (assoc interp :result "0")) ((equal? sub "isdirectory")
((equal? sub "size") (assoc interp :result "0")) (assoc interp :result (if (file-isdir? (first rest-args)) "1" "0")))
((equal? sub "mkdir") (assoc interp :result "")) ((equal? sub "readable")
((equal? sub "copy") (assoc interp :result "")) (assoc interp :result (if (file-readable? (first rest-args)) "1" "0")))
((equal? sub "rename") (assoc interp :result "")) ((equal? sub "writable")
((equal? sub "delete") (assoc interp :result "")) (assoc interp :result (if (file-writable? (first rest-args)) "1" "0")))
((equal? sub "size")
(assoc interp :result (str (file-size (first rest-args)))))
((equal? sub "mtime")
(assoc interp :result (str (file-mtime (first rest-args)))))
((equal? sub "atime")
(let ((s (file-stat (first rest-args))))
(assoc interp :result (if (nil? s) "0" (str (get s :atime))))))
((equal? sub "type")
(let ((s (file-stat (first rest-args))))
(assoc interp :result (if (nil? s) "" (get s :type)))))
((equal? sub "mkdir")
(let ((_ (file-mkdir (first rest-args))))
(assoc interp :result "")))
((equal? sub "copy")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let ((_ (file-copy (first paths) (nth paths 1))))
(assoc interp :result ""))))
((equal? sub "rename")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let ((_ (file-rename (first paths) (nth paths 1))))
(assoc interp :result ""))))
((equal? sub "delete")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let
((_
(reduce
(fn (acc p) (let ((_ (file-delete p))) acc))
nil
paths)))
(assoc interp :result ""))))
(else (error (str "file: unknown subcommand \"" sub "\"")))))))) (else (error (str "file: unknown subcommand \"" sub "\""))))))))
(define (define

View File

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

View File

@@ -303,6 +303,118 @@
:result) :result)
"3") "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)
"")
(dict (dict
"passed" "passed"
tcl-idiom-pass tcl-idiom-pass

View File

@@ -155,9 +155,9 @@ Extract from `haskell/infer.sx`. Algorithm W or J, generalisation, instantiation
| 1 — conformance.sx (prolog + haskell) | [done] | 58dcff26 | Prolog 590/590 (matches baseline). Haskell 156/156 — old script was broken (0/18 was an artefact of a never-matching grep), driver reveals true counts; baseline updated. | | 1 — conformance.sx (prolog + haskell) | [done] | 58dcff26 | Prolog 590/590 (matches baseline). Haskell 156/156 — old script was broken (0/18 was an artefact of a never-matching grep), driver reveals true counts; baseline updated. |
| 2 — prefix.sx (common-lisp + lua) | [partial — pending lua] | 2ef773a3 | common-lisp/runtime.sx ported (47 aliases collapsed into 13 prefix-rename calls); 518/518 vs 309/309 baseline (improvement, no regression). lua/runtime.sx has no pure same-name aliases — every lua- definition wraps custom logic; second consumer pending. | | 2 — prefix.sx (common-lisp + lua) | [partial — pending lua] | 2ef773a3 | common-lisp/runtime.sx ported (47 aliases collapsed into 13 prefix-rename calls); 518/518 vs 309/309 baseline (improvement, no regression). lua/runtime.sx has no pure same-name aliases — every lua- definition wraps custom logic; second consumer pending. |
| 3 — lex.sx (lua + tcl) | [done] | 559b0df9 | lex.sx exports nil-safe char-class predicates + token record. lua/tokenizer.sx (7 preds) and tcl/tokenizer.sx (5 preds) collapsed into prefix-rename calls. lua 185/185, tcl 342/342, tcl-conf 3/4 — all = baseline. | | 3 — lex.sx (lua + tcl) | [done] | 559b0df9 | lex.sx exports nil-safe char-class predicates + token record. lua/tokenizer.sx (7 preds) and tcl/tokenizer.sx (5 preds) collapsed into prefix-rename calls. lua 185/185, tcl 342/342, tcl-conf 3/4 — all = baseline. |
| 4 — pratt.sx (lua + prolog) | [in-progress] | — | — | | 4 — pratt.sx (lua + prolog) | [done] | da27958d | Extracted operator-table format + lookup only — climbing loops stay per-language because lua and prolog use opposite prec conventions. lua/parser.sx: 18-clause cond → 15-entry table. prolog/parser.sx: pl-op-find deleted, pl-op-lookup wraps pratt-op-lookup. lua 185/185, prolog 590/590 — both = baseline. |
| 5 — ast.sx (lua + prolog) | [ ] | — | — | | 5 — ast.sx (lua + prolog) | [partial — pending real consumers] | a774cd26 | Kit + 33 self-tests shipped (10 canonical kinds, predicates, accessors). Step is "Optional" per brief; lua/prolog parsers untouched (185/185 + 590/590). Datalog-on-sx will be the natural first real consumer; lua/prolog converters can land later. |
| 6 — match.sx (haskell + prolog) | [ ] | — | — | | 6 — match.sx (haskell + prolog) | [in-progress] | — | — |
| 7 — layout.sx (haskell + synthetic) | [ ] | — | — | | 7 — layout.sx (haskell + synthetic) | [ ] | — | — |
| 8 — hm.sx (haskell + TBD) | [ ] | — | — | | 8 — hm.sx (haskell + TBD) | [ ] | — | — |

View File

@@ -220,6 +220,77 @@ connections. 358/358 green.**
--- ---
## Phase 5d — File metadata + filesystem ops ✓
Real implementations of `file isfile`/`isdir`/`readable`/`writable`/`size`/
`mtime`/`atime`/`type` (previously stubs returning `0`/`""`) and proper
`file delete`/`mkdir`/`copy`/`rename`.
| Status | Primitive | Wraps |
|---|---|---|
| [x] | `file-size`, `file-mtime`, `file-stat` | `Unix.stat` |
| [x] | `file-isfile?`, `file-isdir?` | `Unix.stat`+`st_kind` |
| [x] | `file-readable?`, `file-writable?` | `Unix.access [R_OK\|W_OK]` |
| [x] | `file-delete` | `Unix.unlink`/`rmdir` (tolerates ENOENT) |
| [x] | `file-mkdir` | recursive `Unix.mkdir 0o755` |
| [x] | `file-copy`, `file-rename` | stdlib I/O / `Sys.rename` |
`file-stat` returns a dict `{:size :mtime :atime :ctime :mode :type}` with
`:type``file|directory|link|fifo|socket|...`. Tcl `file copy`/`rename`/
`delete` strip leading-`-` flags so `file delete -force` works.
**Total: ~half day. 10 new idiom tests covering isfile, isdir on /tmp, size,
readable, mkdir + check, copy roundtrip, rename, mtime > 0. 368/368 green.**
---
## Phase 5e — clock format options + clock scan ✓
Real `-format`, `-timezone`, and `-gmt` options on `clock format`, and a
working `clock scan` for parsing date strings back to Unix seconds.
| Status | Work |
|---|---|
| [x] | `clock-format` extended to `(t fmt tz)` with tz ∈ `utc|local` |
| [x] | More format specifiers: `%y` (2-digit year), `%I` (12h hour), `%p` (AM/PM), `%w` (weekday num), `%%` (literal) |
| [x] | `clock-scan` SX primitive: format-driven parser + manual `timegm` (OCaml stdlib lacks it) |
| [x] | Tcl `clock format $secs -format $fmt -timezone $tz -gmt 0\|1` |
| [x] | Tcl `clock scan $str -format $fmt -timezone $tz -gmt 0\|1` |
Default tz for both is UTC. Format specifiers supported by scan: `%Y %y %m
%d %e %H %I %M %S %%`. Unsupported specifiers in scan are silently skipped
(no validation).
**Total: ~half day. 5 new idiom tests: clock-format-utc, fmt-default,
scan-roundtrip, scan-returns-int, format-percent-pct. 373/373 green.**
---
## Phase 5f — `socket -async` (non-blocking connect) ✓
| Status | Work |
|---|---|
| [x] | `socket-connect-async host port` SX primitive — `Unix.set_nonblock` + `Unix.connect`, catches `EINPROGRESS` |
| [x] | `channel-async-error chan` SX primitive — `Unix.getsockopt_error` |
| [x] | Tcl `socket -async host port` — returns "sockN" immediately |
| [x] | Tcl `fconfigure $chan -error` — queries async-error |
Connection completes when the channel becomes writable; canonical pattern is
`fileevent $sock writable {handler}`. Channel buffer state is set to
`blocking=false` so subsequent reads/writes don't block.
**Total: ~few hours. 3 new idiom tests: socket-async-completes-writable,
socket-async-then-write, socket-async-no-error. 376/376 green.**
**Bug fix landed alongside:** `tcl-call-proc` was discarding `:fileevents`,
`:timers`, and `:procs` updates made inside Tcl procs (only `:commands` was
forwarded). Changed the return to forward the inner `result-interp` as the
base while restoring caller's frame/stack/result/output/code. This was
masked until socket -async made it natural to register a `fileevent` from
inside a proc body (the typical async accept pattern).
---
## Suggested order ## Suggested order
1. **Phase 1** — immediate Tcl wins, zero risk, proves the approach 1. **Phase 1** — immediate Tcl wins, zero risk, proves the approach
@@ -236,6 +307,9 @@ becomes a lasting SX contribution used by every future hosted language.
_Newest first._ _Newest first._
- 2026-05-07: Phase 5f socket -async — socket-connect-async (Unix.set_nonblock+connect/EINPROGRESS) + channel-async-error (getsockopt_error); Tcl `socket -async host port` returns immediately; `fconfigure $sock -error` queries async error; +3 idiom tests; 376/376 green
- 2026-05-07: Phase 5e clock options + scan — clock-format extended with tz arg (utc/local) + more specifiers; new clock-scan primitive with manual timegm; Tcl clock format/scan support -format/-timezone/-gmt; +5 idiom tests; 373/373 green
- 2026-05-07: Phase 5d file ops — file-size/mtime/isfile?/isdir?/readable?/writable?/stat/delete/mkdir/copy/rename SX primitives; Tcl file isfile/isdir/readable/writable/size/mtime/atime/type/mkdir/copy/rename/delete now real; +10 idiom tests; 368/368 green
- 2026-05-07: Phase 5c sockets — socket-connect/socket-server/socket-accept SX primitives wrapping Unix.socket/connect/bind/listen/accept; tcl-cmd-socket dispatches client (host port) vs server (-server cb port); server auto-registers fileevent → _sock-do-accept handler that calls user callback per accept; puts now dispatches "sockN" channels to channel-write too; +4 idiom tests; 358/358 green - 2026-05-07: Phase 5c sockets — socket-connect/socket-server/socket-accept SX primitives wrapping Unix.socket/connect/bind/listen/accept; tcl-cmd-socket dispatches client (host port) vs server (-server cb port); server auto-registers fileevent → _sock-do-accept handler that calls user callback per accept; puts now dispatches "sockN" channels to channel-write too; +4 idiom tests; 358/358 green
- 2026-05-07: Phase 5b event loop — io-select-channels SX primitive + Tcl-side fileevent/after/vwait/update; tcl-event-step drives expired timers + Unix.select on registered channels; +5 idiom tests; 354/354 green - 2026-05-07: Phase 5b event loop — io-select-channels SX primitive + Tcl-side fileevent/after/vwait/update; tcl-event-step drives expired timers + Unix.select on registered channels; +5 idiom tests; 354/354 green
- 2026-05-07: Phase 5 channel I/O — 11 SX primitives (channel-open/close/read/read-line/write/flush/seek/tell/eof?/blocking?/set-blocking!) wrapping Unix.openfile/read/write/lseek/set_nonblock; tcl-cmd-open/close/read/gets-chan/seek/tell/flush rewritten + new tcl-cmd-fconfigure; tcl-cmd-puts dispatches on "fileN" arg; gets registration fixed; +7 idiom tests; 349/349 green - 2026-05-07: Phase 5 channel I/O — 11 SX primitives (channel-open/close/read/read-line/write/flush/seek/tell/eof?/blocking?/set-blocking!) wrapping Unix.openfile/read/write/lseek/set_nonblock; tcl-cmd-open/close/read/gets-chan/seek/tell/flush rewritten + new tcl-cmd-fconfigure; tcl-cmd-puts dispatches on "fileN" arg; gets registration fixed; +7 idiom tests; 349/349 green
@@ -252,8 +326,8 @@ _Newest first._
## What stays out of scope ## What stays out of scope
- `package require` of binary loadables - `package require` of binary loadables (would need `Dynlink` + native ABI design)
- Full `clock format` locale support - Full `clock format` locale (translated month/day names, `LC_TIME`-aware) — Phase 5e covers `-format`/`-timezone`/`-gmt` with English names
- Tk / GUI - Tk / GUI
- Threads (mapped to coroutines only, as planned) - Threads (mapped to coroutines only, as planned)
- Server-mode `vwait` — Phase 5b event loop is scoped to script-mode; from inside a server-handled command it can't see sx_server's stdin scheduler - Server-mode `vwait` — Phase 5b event loop is scoped to script-mode; from inside a server-handled command it can't see sx_server's stdin scheduler