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

lib/tcl/runtime.sx

@@ -354,14 +354,28 @@
   (fn
     (interp args)
     (let
-      ((text (last args))
-        (no-nl
-          (and
-            (> (len args) 1)
-            (equal? (first args) "-nonewline"))))
+      ((no-nl (and (> (len args) 1) (equal? (first args) "-nonewline"))))
       (let
-        ((line (if no-nl text (str text "\n"))))
-        (assoc interp :output (str (get interp :output) line))))))
+        ((args2 (if no-nl (rest args) args)))
+        (let
+          ((maybe-chan (if (> (len args2) 1) (first args2) nil))
+            (is-chan
+              (and
+                (not (nil? maybe-chan))
+                (>= (len maybe-chan) 4)
+                (equal? (slice maybe-chan 0 4) "file"))))
+          (if
+            is-chan
+            (let
+              ((chan (first args2))
+                (text (last args2))
+                (line (if no-nl text (str text "\n"))))
+              (let
+                ((_ (channel-write chan line)))
+                (assoc interp :result "")))
+            (let
+              ((text (last args2)) (line (if no-nl text (str text "\n"))))
+              (assoc interp :output (str (get interp :output) line)))))))))
 
 (define
   tcl-cmd-incr
@@ -2874,30 +2888,108 @@
           ((equal? sub "scan") (assoc interp :result "0"))
           (else (error (str "clock: unknown subcommand \"" sub "\""))))))))
 
-(define tcl-cmd-open (fn (interp args) (assoc interp :result "file0")))
+(define
+  tcl-cmd-open
+  (fn
+    (interp args)
+    (let
+      ((path (first args))
+        (mode (if (> (len args) 1) (nth args 1) "r")))
+      (assoc interp :result (channel-open path mode)))))
 
 ; gets channel ?varname?
-(define tcl-cmd-close (fn (interp args) (assoc interp :result "")))
+(define
+  tcl-cmd-close
+  (fn
+    (interp args)
+    (let ((_ (channel-close (first args)))) (assoc interp :result ""))))
 
-(define tcl-cmd-read (fn (interp args) (assoc interp :result "")))
+(define
+  tcl-cmd-read
+  (fn
+    (interp args)
+    (let
+      ((chan (first args))
+        (n (if (> (len args) 1) (parse-int (nth args 1)) -1)))
+      (assoc
+        interp
+        :result (if (< n 0) (channel-read chan) (channel-read chan n))))))
 
 (define
   tcl-cmd-gets-chan
   (fn
     (interp args)
-    (if
-      (> (len args) 1)
-      (assoc (tcl-var-set interp (nth args 1) "") :result "-1")
-      (assoc interp :result ""))))
+    (let
+      ((chan (first args)) (line (channel-read-line chan)))
+      (if
+        (nil? line)
+        (if
+          (> (len args) 1)
+          (assoc (tcl-var-set interp (nth args 1) "") :result "-1")
+          (assoc interp :result ""))
+        (if
+          (> (len args) 1)
+          (assoc
+            (tcl-var-set interp (nth args 1) line)
+            :result (str (len line)))
+          (assoc interp :result line))))))
 
-(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1")))
+(define
+  tcl-cmd-eof
+  (fn
+    (interp args)
+    (assoc interp :result (if (channel-eof? (first args)) "1" "0"))))
 
-(define tcl-cmd-seek (fn (interp args) (assoc interp :result "")))
+(define
+  tcl-cmd-seek
+  (fn
+    (interp args)
+    (let
+      ((chan (first args))
+        (off (parse-int (nth args 1)))
+        (whence (if (> (len args) 2) (nth args 2) "start")))
+      (let ((_ (channel-seek chan off whence))) (assoc interp :result "")))))
 
 ; file command dispatcher
-(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))
+(define
+  tcl-cmd-tell
+  (fn
+    (interp args)
+    (assoc interp :result (str (channel-tell (first args))))))
+
+(define
+  tcl-cmd-flush
+  (fn
+    (interp args)
+    (let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
+(define
+  tcl-cmd-fconfigure
+  (fn
+    (interp args)
+    (let
+      ((chan (first args)) (rest-args (rest args)))
+      (if
+        (= 0 (len rest-args))
+        (assoc
+          interp
+          :result (str "-blocking " (if (channel-blocking? chan) "1" "0")))
+        (if
+          (and
+            (= 2 (len rest-args))
+            (equal? (first rest-args) "-blocking"))
+          (let
+            ((b (nth rest-args 1)))
+            (let
+              ((_ (channel-set-blocking! chan (not (or (equal? b "0") (equal? b "false"))))))
+              (assoc interp :result "")))
+          (if
+            (and
+              (= 1 (len rest-args))
+              (equal? (first rest-args) "-blocking"))
+            (assoc interp :result (if (channel-blocking? chan) "1" "0"))
+            (assoc interp :result "")))))))
+
 
-(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
 (define
   tcl-cmd-array
   (fn
@@ -2909,11 +3001,16 @@
         ((sub (first args)) (rest-args (rest args)))
         (cond
           ((equal? sub "get")
-            (if (= 0 (len rest-args))
+            (if
+              (= 0 (len rest-args))
               (error "array get: wrong # args")
               (let
                 ((arr-name (first rest-args))
-                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
+                  (pattern
+                    (if
+                      (> (len rest-args) 1)
+                      (nth rest-args 1)
+                      nil)))
                 (let
                   ((prefix (str arr-name "("))
                     (locals (get (get interp :frame) :locals)))
@@ -2922,21 +3019,20 @@
                     (let
                       ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
                       (let
-                        ((filtered
-                            (if
-                              (nil? pattern)
-                              arr-keys
-                              (filter
-                                (fn (k)
-                                  (let ((kn (substring k pl (- (string-length k) 1))))
-                                    (tcl-glob-match (split pattern "") (split kn ""))))
-                                arr-keys))))
-                        (assoc interp :result
-                          (join " "
+                        ((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
+                        (assoc
+                          interp
+                          :result (join
+                            " "
                             (reduce
-                              (fn (acc k)
-                                (let ((kn (substring k pl (- (string-length k) 1))))
-                                  (append acc (list kn) (list (get locals k)))))
+                              (fn
+                                (acc k)
+                                (let
+                                  ((kn (substring k pl (- (string-length k) 1))))
+                                  (append
+                                    acc
+                                    (list kn)
+                                    (list (get locals k)))))
                               (list)
                               filtered))))))))))
           ((equal? sub "set")
@@ -2954,7 +3050,8 @@
                     (assoc acc :result "")
                     (loop
                       (rest (rest pairs))
-                      (tcl-var-set acc
+                      (tcl-var-set
+                        acc
                         (str arr-name "(" (first pairs) ")")
                         (nth pairs 1))))))))
           ((equal? sub "names")
@@ -2963,7 +3060,11 @@
               (error "array names: wrong # args")
               (let
                 ((arr-name (first rest-args))
-                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
+                  (pattern
+                    (if
+                      (> (len rest-args) 1)
+                      (nth rest-args 1)
+                      nil)))
                 (let
                   ((prefix (str arr-name "("))
                     (locals (get (get interp :frame) :locals)))
@@ -2972,17 +3073,19 @@
                     (let
                       ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
                       (let
-                        ((filtered
-                            (if
-                              (nil? pattern)
-                              arr-keys
-                              (filter
-                                (fn (k)
-                                  (let ((kn (substring k pl (- (string-length k) 1))))
-                                    (tcl-glob-match (split pattern "") (split kn ""))))
-                                arr-keys))))
-                        (assoc interp :result
-                          (join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered))))))))))
+                        ((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
+                        (assoc
+                          interp
+                          :result (join
+                            " "
+                            (map
+                              (fn
+                                (k)
+                                (substring
+                                  k
+                                  pl
+                                  (- (string-length k) 1)))
+                              filtered))))))))))
           ((equal? sub "size")
             (if
               (= 0 (len rest-args))
@@ -2990,8 +3093,13 @@
               (let
                 ((prefix (str (first rest-args) "("))
                   (locals (get (get interp :frame) :locals)))
-                (assoc interp :result
-                  (str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))))))
+                (assoc
+                  interp
+                  :result (str
+                    (len
+                      (filter
+                        (fn (k) (tcl-starts-with? k prefix))
+                        (keys locals))))))))
           ((equal? sub "exists")
             (if
               (= 0 (len rest-args))
@@ -2999,44 +3107,39 @@
               (let
                 ((prefix (str (first rest-args) "("))
                   (locals (get (get interp :frame) :locals)))
-                (assoc interp :result
-                  (if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0")))))
+                (assoc
+                  interp
+                  :result (if
+                    (>
+                      (len
+                        (filter
+                          (fn (k) (tcl-starts-with? k prefix))
+                          (keys locals)))
+                      0)
+                    "1"
+                    "0")))))
           ((equal? sub "unset")
             (if
               (= 0 (len rest-args))
               (error "array unset: wrong # args")
               (let
                 ((arr-name (first rest-args))
-                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
+                  (pattern
+                    (if
+                      (> (len rest-args) 1)
+                      (nth rest-args 1)
+                      nil)))
                 (let
                   ((prefix (str arr-name "("))
                     (locals (get (get interp :frame) :locals)))
                   (let
                     ((pl (string-length prefix)))
                     (let
-                      ((to-delete
-                          (filter
-                            (fn (k)
-                              (if
-                                (tcl-starts-with? k prefix)
-                                (if
-                                  (nil? pattern)
-                                  true
-                                  (let ((kn (substring k pl (- (string-length k) 1))))
-                                    (tcl-glob-match (split pattern "") (split kn ""))))
-                                false))
-                            (keys locals))))
+                      ((to-delete (filter (fn (k) (if (tcl-starts-with? k prefix) (if (nil? pattern) true (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) false)) (keys locals))))
                       (let
-                        ((new-locals
-                            (reduce
-                              (fn (acc k)
-                                (if
-                                  (contains? to-delete k)
-                                  acc
-                                  (assoc acc k (get locals k))))
-                              {}
-                              (keys locals))))
-                        (assoc interp
+                        ((new-locals (reduce (fn (acc k) (if (contains? to-delete k) acc (assoc acc k (get locals k)))) {} (keys locals))))
+                        (assoc
+                          interp
                           :frame (assoc (get interp :frame) :locals new-locals)
                           :result ""))))))))
           (else (error (str "array: unknown subcommand \"" sub "\""))))))))
@@ -3048,7 +3151,7 @@
     (interp args)
     (if
       (< (len args) 1)
-      (error "apply: wrong # args: should be "apply lambdaList ?arg ...?"")
+      (error "apply: wrong # args: should be " apply lambdaList ?arg ...? "")
       (let
         ((func-list (tcl-list-split (first args)))
           (call-args (rest args)))
@@ -3058,90 +3161,122 @@
           (let
             ((param-spec (first func-list))
               (body (nth func-list 1))
-              (ns (if (> (len func-list) 2) (nth func-list 2) nil)))
+              (ns
+                (if
+                  (> (len func-list) 2)
+                  (nth func-list 2)
+                  nil)))
             (let
               ((proc-def {:args param-spec :body body :ns ns}))
               (tcl-call-proc interp "#apply" proc-def call-args))))))))
 
-
 (define
   tcl-cmd-regexp
   (fn
     (interp args)
-    (define parse-flags
-      (fn (as nocase? all? inline?)
-        (if (= 0 (len as))
-          {:nocase nocase? :all all? :inline inline? :rest as}
+    (define
+      parse-flags
+      (fn
+        (as nocase? all? inline?)
+        (if
+          (= 0 (len as))
+          {:rest as :nocase nocase? :inline inline? :all all?}
           (cond
-            ((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
-            ((equal? (first as) "-all")    (parse-flags (rest as) nocase? true inline?))
-            ((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
-            (else {:nocase nocase? :all all? :inline inline? :rest as})))))
-    (let ((pf (parse-flags args false false false)))
-      (let ((nocase (get pf :nocase))
-            (all-mode (get pf :all))
-            (inline-mode (get pf :inline))
-            (ra (get pf :rest)))
-        (if (< (len ra) 2)
+            ((equal? (first as) "-nocase")
+              (parse-flags (rest as) true all? inline?))
+            ((equal? (first as) "-all")
+              (parse-flags (rest as) nocase? true inline?))
+            ((equal? (first as) "-inline")
+              (parse-flags (rest as) nocase? all? true))
+            (else {:rest as :nocase nocase? :inline inline? :all all?})))))
+    (let
+      ((pf (parse-flags args false false false)))
+      (let
+        ((nocase (get pf :nocase))
+          (all-mode (get pf :all))
+          (inline-mode (get pf :inline))
+          (ra (get pf :rest)))
+        (if
+          (< (len ra) 2)
           (error "regexp: wrong # args")
-          (let ((pattern (first ra))
-                (str-val (nth ra 1))
-                (var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
-            (let ((re (make-regexp pattern (if nocase "i" ""))))
-              (if all-mode
-                (assoc interp :result (str (len (regexp-match-all re str-val))))
-                (if inline-mode
-                  (assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
-                  (let ((m (regexp-match re str-val)))
-                    (if (nil? m)
+          (let
+            ((pattern (first ra))
+              (str-val (nth ra 1))
+              (var-args
+                (if (> (len ra) 2) (rest (rest ra)) (list))))
+            (let
+              ((re (make-regexp pattern (if nocase "i" ""))))
+              (if
+                all-mode
+                (assoc
+                  interp
+                  :result (str (len (regexp-match-all re str-val))))
+                (if
+                  inline-mode
+                  (assoc
+                    interp
+                    :result (join
+                      " "
+                      (map
+                        (fn (m) (get m :match))
+                        (regexp-match-all re str-val))))
+                  (let
+                    ((m (regexp-match re str-val)))
+                    (if
+                      (nil? m)
                       (assoc interp :result "0")
-                      (let ((interp2
-                              (if (> (len var-args) 0)
-                                (tcl-var-set interp (first var-args) (get m :match))
-                                interp)))
-                        (let ((interp3
-                                (let loop ((vi 1) (gs (get m :groups)) (acc interp2))
-                                  (if (or (= 0 (len gs)) (>= vi (len var-args))) acc
-                                    (loop (+ vi 1) (rest gs)
-                                          (tcl-var-set acc (nth var-args vi) (first gs)))))))
+                      (let
+                        ((interp2 (if (> (len var-args) 0) (tcl-var-set interp (first var-args) (get m :match)) interp)))
+                        (let
+                          ((interp3 (let loop ((vi 1) (gs (get m :groups)) (acc interp2)) (if (or (= 0 (len gs)) (>= vi (len var-args))) acc (loop (+ vi 1) (rest gs) (tcl-var-set acc (nth var-args vi) (first gs)))))))
                           (assoc interp3 :result "1"))))))))))))))
 
+
+
 (define
   tcl-cmd-regsub
   (fn
     (interp args)
-    (define parse-flags
-      (fn (as all? nocase?)
-        (if (= 0 (len as))
-          {:all all? :nocase nocase? :rest as}
+    (define
+      parse-flags
+      (fn
+        (as all? nocase?)
+        (if
+          (= 0 (len as))
+          {:rest as :nocase nocase? :all all?}
           (cond
-            ((equal? (first as) "-all")    (parse-flags (rest as) true nocase?))
-            ((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
-            (else {:all all? :nocase nocase? :rest as})))))
-    (let ((pf (parse-flags args false false)))
-      (let ((all-mode (get pf :all))
-            (nocase (get pf :nocase))
-            (ra (get pf :rest)))
-        (if (< (len ra) 3)
+            ((equal? (first as) "-all")
+              (parse-flags (rest as) true nocase?))
+            ((equal? (first as) "-nocase")
+              (parse-flags (rest as) all? true))
+            (else {:rest as :nocase nocase? :all all?})))))
+    (let
+      ((pf (parse-flags args false false)))
+      (let
+        ((all-mode (get pf :all))
+          (nocase (get pf :nocase))
+          (ra (get pf :rest)))
+        (if
+          (< (len ra) 3)
           (error "regsub: wrong # args")
-          (let ((pattern (first ra))
-                (str-val (nth ra 1))
-                (replacement (nth ra 2))
-                (var-name (if (> (len ra) 3) (nth ra 3) nil)))
-            (let ((re (make-regexp pattern (if nocase "i" ""))))
-              (let ((result
-                      (if all-mode
-                        (regexp-replace-all re str-val replacement)
-                        (regexp-replace re str-val replacement))))
-                (if (nil? var-name)
+          (let
+            ((pattern (first ra))
+              (str-val (nth ra 1))
+              (replacement (nth ra 2))
+              (var-name
+                (if (> (len ra) 3) (nth ra 3) nil)))
+            (let
+              ((re (make-regexp pattern (if nocase "i" ""))))
+              (let
+                ((result (if all-mode (regexp-replace-all re str-val replacement) (regexp-replace re str-val replacement))))
+                (if
+                  (nil? var-name)
                   (assoc interp :result result)
-                  (let ((count
-                          (if all-mode
-                            (len (regexp-match-all re str-val))
-                            (if (nil? (regexp-match re str-val)) 0 1))))
-                    (assoc (tcl-var-set interp var-name result) :result (str count))))))))))))
-
-
+                  (let
+                    ((count (if all-mode (len (regexp-match-all re str-val)) (if (nil? (regexp-match re str-val)) 0 1))))
+                    (assoc
+                      (tcl-var-set interp var-name result)
+                      :result (str count))))))))))))
 
 (define
   tcl-cmd-file
@@ -3153,7 +3288,10 @@
       (let
         ((sub (first args)) (rest-args (rest args)))
         (cond
-          ((equal? sub "exists") (assoc interp :result (if (file-exists? (first rest-args)) "1" "0")))
+          ((equal? sub "exists")
+            (assoc
+              interp
+              :result (if (file-exists? (first rest-args)) "1" "0")))
           ((equal? sub "join") (assoc interp :result (join "/" rest-args)))
           ((equal? sub "split")
             (assoc
@@ -3254,7 +3392,7 @@
                                       (let
                                         ((i (tcl-register i "expr" tcl-cmd-expr)))
                                         (let
-                                          ((i (tcl-register i "gets" tcl-cmd-gets)))
+                                          ((i (tcl-register i "gets" tcl-cmd-gets-chan)))
                                           (let
                                             ((i (tcl-register i "subst" tcl-cmd-subst)))
                                             (let
@@ -3331,6 +3469,17 @@
                                                                                                                     ((i (tcl-register i "tell" tcl-cmd-tell)))
                                                                                                                     (let
                                                                                                                       ((i (tcl-register i "flush" tcl-cmd-flush)))
-                                                                                                                      (let ((i (tcl-register i "file" tcl-cmd-file)))
-                                                                                                                      (let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
-                                                                                                                        (let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+                                                                                                                      (let
+                                                                                                                        ((i (tcl-register i "fconfigure" tcl-cmd-fconfigure)))
+                                                                                                                        (let
+                                                                                                                          ((i (tcl-register i "file" tcl-cmd-file)))
+                                                                                                                          (let
+                                                                                                                            ((i (tcl-register i "regexp" tcl-cmd-regexp)))
+                                                                                                                            (let
+                                                                                                                              ((i (tcl-register i "regsub" tcl-cmd-regsub)))
+                                                                                                                              (let
+                                                                                                                                ((i (tcl-register i "apply" tcl-cmd-apply)))
+                                                                                                                                (tcl-register
+                                                                                                                                  i
+                                                                                                                                  "array"
+                                                                                                                                  tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

lib/tcl/test.sh

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

lib/tcl/tests/coro.sx

@@ -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

lib/tcl/tests/idioms.sx

@@ -187,6 +187,57 @@
           (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")
+
     (dict
       "passed"
       tcl-idiom-pass