tcl: Phase 3 OCaml primitives — file I/O + clock; refresh prolog scoreboard

file-read/write/append/exists?/glob + clock-seconds/milliseconds/format registered in sx_primitives.ml; unix dep added to dune. Unlocks Tcl open/read/puts-to-file, glob, clock seconds/format commands. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-06 18:27:48 +00:00
parent 74e020359f
commit 2249863d2d
5 changed files with 160 additions and 13 deletions
--- a/hosts/ocaml/lib/dune
+++ b/hosts/ocaml/lib/dune
@@ -1,4 +1,4 @@
 (library
 (name sx)
 (wrapped false)
- (libraries re re.pcre))
+ (libraries re re.pcre unix))
--- a/hosts/ocaml/lib/sx_primitives.ml
+++ b/hosts/ocaml/lib/sx_primitives.ml
@@ -3000,4 +3000,142 @@ let () =
      List.iteri (fun i c -> Bytes.set b i c) bytes_list;
      SxBytevector b
    | [Nil] -> SxBytevector (Bytes.create 0)
-    | _ -> raise (Eval_error "list->bytevector: expected list"))
+    | _ -> raise (Eval_error "list->bytevector: expected list"));
+
+  (* === File I/O === *)
+  register "file-read" (fun args ->
+    match args with
+    | [String path] ->
+      (try
+        let ic = open_in path in
+        let n = in_channel_length ic in
+        let s = Bytes.create n in
+        really_input ic s 0 n;
+        close_in ic;
+        String (Bytes.to_string s)
+      with Sys_error msg -> raise (Eval_error ("file-read: " ^ msg)))
+    | _ -> raise (Eval_error "file-read: (path)"));
+
+  register "file-write" (fun args ->
+    match args with
+    | [String path; String content] ->
+      (try
+        let oc = open_out path in
+        output_string oc content;
+        close_out oc;
+        Nil
+      with Sys_error msg -> raise (Eval_error ("file-write: " ^ msg)))
+    | _ -> raise (Eval_error "file-write: (path content)"));
+
+  register "file-append" (fun args ->
+    match args with
+    | [String path; String content] ->
+      (try
+        let oc = open_out_gen [Open_append; Open_creat; Open_wronly; Open_text] 0o644 path in
+        output_string oc content;
+        close_out oc;
+        Nil
+      with Sys_error msg -> raise (Eval_error ("file-append: " ^ msg)))
+    | _ -> raise (Eval_error "file-append: (path content)"));
+
+  register "file-exists?" (fun args ->
+    match args with
+    | [String path] -> Bool (Sys.file_exists path)
+    | _ -> raise (Eval_error "file-exists?: (path)"));
+
+  register "file-glob" (fun args ->
+    let glob_match pat str =
+      let pn = String.length pat and sn = String.length str in
+      let rec go pi si =
+        if pi = pn then si = sn
+        else match pat.[pi] with
+          | '*' ->
+            let rec try_from i = i <= sn && (go (pi+1) i || try_from (i+1)) in
+            try_from si
+          | '?' -> si < sn && go (pi+1) (si+1)
+          | '[' ->
+            let pi' = ref (pi+1) in
+            let negate = !pi' < pn && pat.[!pi'] = '^' in
+            if negate then incr pi';
+            let matched = ref false in
+            while !pi' < pn && pat.[!pi'] <> ']' do
+              let c1 = pat.[!pi'] in
+              incr pi';
+              if !pi' + 1 < pn && pat.[!pi'] = '-' then begin
+                let c2 = pat.[!pi' + 1] in
+                pi' := !pi' + 2;
+                if si < sn && str.[si] >= c1 && str.[si] <= c2 then matched := true
+              end else if si < sn && str.[si] = c1 then matched := true
+            done;
+            if !pi' < pn then incr pi';
+            ((!matched && not negate) || (not !matched && negate)) && go !pi' (si+1)
+          | c -> si < sn && str.[si] = c && go (pi+1) (si+1)
+      in go 0 0
+    in
+    let glob_paths pat =
+      let dir = Filename.dirname pat in
+      let base_pat = Filename.basename pat in
+      let dir' = if dir = "." && not (String.length pat > 1 && pat.[0] = '.') then "." else dir in
+      (try
+        let entries = Sys.readdir dir' in
+        Array.fold_left (fun acc entry ->
+          if glob_match base_pat entry then
+            let full = if dir' = "." then entry else Filename.concat dir' entry in
+            full :: acc
+          else acc
+        ) [] entries
+        |> List.sort String.compare
+      with Sys_error _ -> [])
+    in
+    match args with
+    | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
+    | _ -> raise (Eval_error "file-glob: (pattern)"));
+
+  (* === Clock === *)
+  register "clock-seconds" (fun args ->
+    match args with
+    | [] -> Integer (int_of_float (Unix.gettimeofday ()))
+    | _ -> raise (Eval_error "clock-seconds: no args"));
+
+  register "clock-milliseconds" (fun args ->
+    match args with
+    | [] -> 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 buf = Buffer.create 32 in
+      let n = String.length fmt in
+      let i = ref 0 in
+      while !i < n do
+        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))
+           | '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)
+           | '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"
+           | '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
+                    Buffer.add_string buf days.(tm.Unix.tm_wday)
+           | 'b' | 'h' -> let mons = [|"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"|] in
+                    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)
+           | c -> Buffer.add_char buf '%'; Buffer.add_char buf c);
+          i := !i + 2
+        end else begin
+          Buffer.add_char buf fmt.[!i];
+          incr i
+        end
+      done;
+      String (Buffer.contents buf)
+    | _ -> raise (Eval_error "clock-format: (seconds [format])"))
--- a/lib/prolog/scoreboard.json
+++ b/lib/prolog/scoreboard.json
@@ -3,5 +3,5 @@
  "total_failed": 0,
  "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}},
-  "generated": "2026-05-06T08:29:09+00:00"
+  "generated": "2026-05-06T12:17:46+00:00"
 }
--- a/lib/prolog/scoreboard.md
+++ b/lib/prolog/scoreboard.md
@@ -1,7 +1,7 @@
 # Prolog scoreboard

 **590 / 590 passing** (0 failure(s)).
-Generated 2026-05-06T08:29:09+00:00.
+Generated 2026-05-06T12:17:46+00:00.

 | Suite | Passed | Total | Status |
 |-------|--------|-------|--------|
--- a/plans/tcl-sx-completion.md
+++ b/plans/tcl-sx-completion.md
@@ -34,7 +34,7 @@ Everything here is pure Tcl implementation work.
 | [x] | Float in `expr` — detect `.` in number tokens, route through float ops instead of `parse-int` | half day | `expr {3.14 * 2}`, `expr {sqrt(2.0)}`, float comparisons |
 | [x] | `regexp pattern str` and `regsub pattern str repl` wrapping existing SX primitives | few hours | pattern matching, text processing |
 | [x] | `apply {args body} ?arg…?` — anonymous proc call | 1 hour | higher-order functions, `lmap` idiom |
-| [ ] | `array get/set/names/size/exists/unset` commands | half day | array variables (tokenizer already parses `$arr(key)`) |
+| [x] | `array get/set/names/size/exists/unset` commands | half day | array variables (tokenizer already parses `$arr(key)`) |

 **Total: ~2 days. Zero SX changes.**

@@ -42,6 +42,11 @@ Everything here is pure Tcl implementation work.

 ## Phase 2 — `lib/fiber.sx` (pure SX library, no OCaml)

+| Status | Work |
+|---|---|
+| [x] | Create `lib/fiber.sx` — `make-fiber` / `fiber-resume` / `fiber-done?` |
+| [x] | Rewrite `tcl-cmd-coroutine` to use `make-fiber` (true suspension) |
+
 `call/cc` is multi-shot and `set!` on closed-over vars both work. Fibers are
 implementable as a pure SX library using symmetric continuation swapping:

@@ -87,14 +92,14 @@ Tcl coroutines then rewrite using `make-fiber` for true suspension.
 Each is ~10–20 lines of OCaml. All are useful across the whole platform, not
 just Tcl.

-| Primitive | OCaml effort | Unlocks |
-|---|---|---|
-| `(file-read path)` → string | tiny | Tcl `open`/`read`, SX scripts reading files |
-| `(file-write path str)` → nil | tiny | Tcl `open`/`puts` to files |
-| `(file-exists? path)` → bool | tiny | Tcl `file exists` |
-| `(file-glob pattern)` → list | small | Tcl `glob` |
-| `(clock-seconds)` → int | tiny | Tcl `clock seconds` |
-| `(clock-format n fmt)` → string | small (wraps `strftime`) | Tcl `clock format` |
+| Status | Primitive | OCaml effort | Unlocks |
+|---|---|---|---|
+| [x] | `(file-read path)` → string | tiny | Tcl `open`/`read`, SX scripts reading files |
+| [x] | `(file-write path str)` → nil | tiny | Tcl `open`/`puts` to files |
+| [x] | `(file-exists? path)` → bool | tiny | Tcl `file exists` |
+| [x] | `(file-glob pattern)` → list | small | Tcl `glob` |
+| [x] | `(clock-seconds)` → int | tiny | Tcl `clock seconds` |
+| [x] | `(clock-format n fmt)` → string | small (wraps `strftime`) | Tcl `clock format` |

 **Total: 1 day. One focused afternoon of OCaml.**

@@ -141,6 +146,10 @@ becomes a lasting SX contribution used by every future hosted language.

 _Newest first._

+- 2026-05-06: Phase 3 OCaml primitives — file-read/write/append/exists?/glob + clock-seconds/milliseconds/format in sx_primitives.ml + unix dep; tcl-cmd-clock/file wired up; 337/337 green
+- 2026-05-06: Phase 2 coroutine rewrite — `tcl-cmd-coroutine` now creates a `make-fiber`; `tcl-cmd-yield` calls `:coro-yield-fn` (threaded through interp); true suspension; 337/337 green
+- 2026-05-06: Phase 2 fiber.sx — `make-fiber`/`fiber-resume`/`fiber-done?` using call/cc + set!; bidirectional value passing; generator and echo tests pass
+- 2026-05-06: Phase 1 array — `tcl-cmd-array` get/set/names/size/exists/unset; frame-local key scanning with prefix `arrname(`; 337/337 tests green
 - 2026-05-06: Phase 1 apply — `tcl-cmd-apply` wraps `tcl-call-proc`, parses `{args body}` funcList, full frame isolation; 329/329 tests green
 - 2026-05-06: Phase 1 regexp/regsub — `tcl-cmd-regexp`/`tcl-cmd-regsub` wrapping `make-regexp`/`regexp-match`/`regexp-match-all`/`regexp-replace`/`regexp-replace-all`; -nocase/-all/-inline/-all flags; matchVar + subgroup capture; 329/329 tests green
 - 2026-05-06: Phase 1 float expr — `tcl-num-float?`, `tcl-parse-num`, float-aware `tcl-apply-binop`/`tcl-apply-func`/unary-minus/`**`; `sqrt`/`floor`/`ceil`/`round`/`sin`/`cos`/`tan`/`pow`/`exp`/`log` all float-native; 329/329 tests green