tcl: Phase 5 channel I/O — open/read/gets/puts/seek/tell/eof/fconfigure

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>

hosts/ocaml/lib/sx_primitives.ml

@@ -3091,6 +3091,179 @@ let () =
     | [String pat] -> List (List.map (fun s -> String s) (glob_paths pat))
     | _ -> raise (Eval_error "file-glob: (pattern)"));
 
+  (* === 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)"));
+
   (* === Clock === *)
   register "clock-seconds" (fun args ->
     match args with