diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 603248d8..bd30b828 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/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 diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index d8c77649..81bf37c4 100644 --- a/lib/tcl/runtime.sx +++ b/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))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index 445db51d..c36a9440 100755 --- a/lib/tcl/test.sh +++ b/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 diff --git a/lib/tcl/tests/coro.sx b/lib/tcl/tests/coro.sx index 925844e7..b53ed31f 100644 --- a/lib/tcl/tests/coro.sx +++ b/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 diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index c5009adb..b84aaafd 100644 --- a/lib/tcl/tests/idioms.sx +++ b/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