diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 0ed7b8cf..a61634f1 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -528,6 +528,183 @@ let () = | [Rational (_, d)] -> Integer d | [Integer _] -> Integer 1 | _ -> raise (Eval_error "denominator: expected rational or integer")); + (* printf-spec: apply one Tcl/printf format spec to one arg. + spec is like "%5.2f", "%-10s", "%x", "%c", "%d". Always starts with % + and ends with the conversion char. Supports d i u x X o c s f e g. + Coerces arg to the right type per conversion. *) + register "printf-spec" (fun args -> + let spec_str, arg = match args with + | [String s; v] -> (s, v) + | _ -> raise (Eval_error "printf-spec: (spec arg)") + in + let n = String.length spec_str in + if n < 2 || spec_str.[0] <> '%' then + raise (Eval_error ("printf-spec: invalid spec " ^ spec_str)); + let type_char = spec_str.[n - 1] in + let to_int v = match v with + | Integer i -> i + | Number f -> int_of_float f + | String s -> + let s = String.trim s in + (try int_of_string s + with _ -> + try int_of_float (float_of_string s) + with _ -> 0) + | Bool true -> 1 | Bool false -> 0 + | _ -> 0 + in + let to_float v = match v with + | Number f -> f + | Integer i -> float_of_int i + | String s -> + let s = String.trim s in + (try float_of_string s with _ -> 0.0) + | _ -> 0.0 + in + let to_string v = match v with + | String s -> s + | Integer i -> string_of_int i + | Number f -> Sx_types.format_number f + | Bool true -> "1" | Bool false -> "0" + | Nil -> "" + | _ -> Sx_types.inspect v + in + try + match type_char with + | 'd' | 'i' -> + let fmt = Scanf.format_from_string spec_str "%d" in + String (Printf.sprintf fmt (to_int arg)) + | 'u' -> + let fmt = Scanf.format_from_string spec_str "%u" in + String (Printf.sprintf fmt (to_int arg)) + | 'x' -> + let fmt = Scanf.format_from_string spec_str "%x" in + String (Printf.sprintf fmt (to_int arg)) + | 'X' -> + let fmt = Scanf.format_from_string spec_str "%X" in + String (Printf.sprintf fmt (to_int arg)) + | 'o' -> + let fmt = Scanf.format_from_string spec_str "%o" in + String (Printf.sprintf fmt (to_int arg)) + | 'c' -> + let n_val = to_int arg in + let body = String.sub spec_str 0 (n - 1) in + let fmt = Scanf.format_from_string (body ^ "s") "%s" in + String (Printf.sprintf fmt (String.make 1 (Char.chr (n_val land 0xff)))) + | 's' -> + let fmt = Scanf.format_from_string spec_str "%s" in + String (Printf.sprintf fmt (to_string arg)) + | 'f' -> + let fmt = Scanf.format_from_string spec_str "%f" in + String (Printf.sprintf fmt (to_float arg)) + | 'e' -> + let fmt = Scanf.format_from_string spec_str "%e" in + String (Printf.sprintf fmt (to_float arg)) + | 'E' -> + let fmt = Scanf.format_from_string spec_str "%E" in + String (Printf.sprintf fmt (to_float arg)) + | 'g' -> + let fmt = Scanf.format_from_string spec_str "%g" in + String (Printf.sprintf fmt (to_float arg)) + | 'G' -> + let fmt = Scanf.format_from_string spec_str "%G" in + String (Printf.sprintf fmt (to_float arg)) + | _ -> raise (Eval_error ("printf-spec: unsupported conversion " ^ String.make 1 type_char)) + with + | Eval_error _ as e -> raise e + | _ -> raise (Eval_error ("printf-spec: invalid format " ^ spec_str))); + + (* scan-spec: apply one Tcl/scanf format spec to a string. + Returns (consumed-count . parsed-value), or nil on failure. *) + register "scan-spec" (fun args -> + let spec_str, str = match args with + | [String s; String input] -> (s, input) + | _ -> raise (Eval_error "scan-spec: (spec input)") + in + let n = String.length spec_str in + if n < 2 || spec_str.[0] <> '%' then + raise (Eval_error ("scan-spec: invalid spec " ^ spec_str)); + let type_char = spec_str.[n - 1] in + let len = String.length str in + (* skip leading whitespace for non-%c/%s conversions *) + let i = ref 0 in + if type_char <> 'c' then + while !i < len && (str.[!i] = ' ' || str.[!i] = '\t' || str.[!i] = '\n') do incr i done; + let start = !i in + try + match type_char with + | 'd' | 'i' -> + let j = ref !i in + if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j; + while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done; + if !j > start && (str.[start] >= '0' && str.[start] <= '9' + || (!j > start + 1 && (str.[start] = '-' || str.[start] = '+'))) then + let n_val = int_of_string (String.sub str start (!j - start)) in + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (Integer n_val); + Hashtbl.replace d "consumed" (Integer !j); + Dict d + else Nil + | 'x' | 'X' -> + let j = ref !i in + while !j < len && + ((str.[!j] >= '0' && str.[!j] <= '9') || + (str.[!j] >= 'a' && str.[!j] <= 'f') || + (str.[!j] >= 'A' && str.[!j] <= 'F')) do incr j done; + if !j > start then + let n_val = int_of_string ("0x" ^ String.sub str start (!j - start)) in + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (Integer n_val); + Hashtbl.replace d "consumed" (Integer !j); + Dict d + else Nil + | 'o' -> + let j = ref !i in + while !j < len && str.[!j] >= '0' && str.[!j] <= '7' do incr j done; + if !j > start then + let n_val = int_of_string ("0o" ^ String.sub str start (!j - start)) in + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (Integer n_val); + Hashtbl.replace d "consumed" (Integer !j); + Dict d + else Nil + | 'f' | 'e' | 'g' -> + let j = ref !i in + if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j; + while !j < len && ((str.[!j] >= '0' && str.[!j] <= '9') || str.[!j] = '.') do incr j done; + if !j < len && (str.[!j] = 'e' || str.[!j] = 'E') then begin + incr j; + if !j < len && (str.[!j] = '-' || str.[!j] = '+') then incr j; + while !j < len && str.[!j] >= '0' && str.[!j] <= '9' do incr j done + end; + if !j > start then + let f_val = float_of_string (String.sub str start (!j - start)) in + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (Number f_val); + Hashtbl.replace d "consumed" (Integer !j); + Dict d + else Nil + | 's' -> + let j = ref !i in + while !j < len && str.[!j] <> ' ' && str.[!j] <> '\t' && str.[!j] <> '\n' do incr j done; + if !j > start then + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (String (String.sub str start (!j - start))); + Hashtbl.replace d "consumed" (Integer !j); + Dict d + else Nil + | 'c' -> + if !i < len then + let d = Hashtbl.create 2 in + Hashtbl.replace d "value" (Integer (Char.code str.[!i])); + Hashtbl.replace d "consumed" (Integer (!i + 1)); + Dict d + else Nil + | _ -> raise (Eval_error ("scan-spec: unsupported conversion " ^ String.make 1 type_char)) + with + | Eval_error _ as e -> raise e + | _ -> Nil); + register "parse-int" (fun args -> let parse_leading_int s = let len = String.length s in @@ -3399,6 +3576,62 @@ let () = Nil | _ -> raise (Eval_error "channel-set-blocking!: (channel bool)")); + (* === Exec === run an external process; capture stdout *) + register "exec-process" (fun args -> + let items = match args with + | [List xs] | [ListRef { contents = xs }] -> xs + | _ -> raise (Eval_error "exec-process: (cmd-list)") + in + let argv = Array.of_list (List.map (function + | String s -> s + | v -> Sx_types.inspect v + ) items) in + if Array.length argv = 0 then raise (Eval_error "exec: empty command"); + let (out_r, out_w) = Unix.pipe () in + let (err_r, err_w) = Unix.pipe () in + let pid = + try Unix.create_process argv.(0) argv Unix.stdin out_w err_w + with Unix.Unix_error (e, _, _) -> + Unix.close out_r; Unix.close out_w; + Unix.close err_r; Unix.close err_w; + raise (Eval_error ("exec: " ^ Unix.error_message e)) + in + Unix.close out_w; + Unix.close err_w; + let buf = Buffer.create 256 in + let errbuf = Buffer.create 64 in + let chunk = Bytes.create 4096 in + let read_all fd target = + try + let stop = ref false in + while not !stop do + let n = Unix.read fd chunk 0 (Bytes.length chunk) in + if n = 0 then stop := true + else Buffer.add_subbytes target chunk 0 n + done + with _ -> () + in + read_all out_r buf; + read_all err_r errbuf; + Unix.close out_r; + Unix.close err_r; + let (_, status) = Unix.waitpid [] pid in + let exit_code = match status with + | Unix.WEXITED n -> n + | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> 1 + in + let s = Buffer.contents buf in + let trimmed = + if String.length s > 0 && s.[String.length s - 1] = '\n' + then String.sub s 0 (String.length s - 1) else s + in + if exit_code <> 0 then + raise (Eval_error ("exec: child exited " ^ string_of_int exit_code + ^ (if Buffer.length errbuf > 0 + then ": " ^ Buffer.contents errbuf + else ""))) + else String trimmed); + (* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *) let resolve_inet_addr host = if host = "" || host = "0.0.0.0" then Unix.inet_addr_any diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index e72928aa..666e92d7 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -73,59 +73,106 @@ (fn (full-stack level) (nth full-stack level))) +; True if name starts with "::" (absolute namespace reference; for now we +; treat any "::name" as the global variable `name`). Multi-level namespace +; paths like "::ns::var" are not yet split — they're stored under the +; literal name in the global frame. +; Hot path on every var-get/set; only one char-at on the typical fast path. +(define + tcl-global-ref? + (fn (name) + (and + (equal? (char-at name 0) ":") + (equal? (char-at name 1) ":")))) + +(define + tcl-strip-global + (fn (name) + (substring name 2 (string-length name)))) + (define tcl-var-get (fn (interp name) - (let - ((val (frame-lookup (get interp :frame) name))) - (if - (nil? val) - (error (str "can't read \"" name "\": no such variable")) + (if + (tcl-global-ref? name) + ; absolute reference — look up in global (root) frame + (let + ((root-frame + (let ((stack (get interp :frame-stack))) + (if (= 0 (len stack)) (get interp :frame) (first stack)))) + (gname (tcl-strip-global name))) + (let ((val (frame-lookup root-frame gname))) + (if + (nil? val) + (error (str "can't read \"" name "\": no such variable")) + val))) + (let + ((val (frame-lookup (get interp :frame) name))) (if - (upvar-alias? val) - ; follow alias to target frame - (let - ((target-level (get val :upvar-level)) - (target-name (get val :upvar-name))) + (nil? val) + (error (str "can't read \"" name "\": no such variable")) + (if + (upvar-alias? val) + ; follow alias to target frame (let - ((full-stack (tcl-full-stack interp))) + ((target-level (get val :upvar-level)) + (target-name (get val :upvar-name))) (let - ((target-frame (tcl-frame-nth full-stack target-level))) + ((full-stack (tcl-full-stack interp))) (let - ((target-val (frame-lookup target-frame target-name))) - (if - (nil? target-val) - (error (str "can't read \"" name "\": no such variable")) - target-val))))) - val))))) + ((target-frame (tcl-frame-nth full-stack target-level))) + (let + ((target-val (frame-lookup target-frame target-name))) + (if + (nil? target-val) + (error (str "can't read \"" name "\": no such variable")) + target-val))))) + val)))))) (define tcl-var-set (fn (interp name val) - (let - ((cur-val (get (get (get interp :frame) :locals) name))) - (if - (and (not (nil? cur-val)) (upvar-alias? cur-val)) - ; set in target frame + (cond + ((tcl-global-ref? name) + ; absolute reference — set in global (root) frame (let - ((target-level (get cur-val :upvar-level)) - (target-name (get cur-val :upvar-name))) - (let - ((full-stack (tcl-full-stack interp))) + ((stack (get interp :frame-stack)) (gname (tcl-strip-global name))) + (if + (= 0 (len stack)) + ; no frame stack — current frame is the root + (assoc interp :frame (frame-set-top (get interp :frame) gname val)) (let - ((target-frame (tcl-frame-nth full-stack target-level))) + ((root-frame (first stack)) + (rest-stack (rest stack))) + (assoc + interp + :frame-stack + (cons (frame-set-top root-frame gname val) rest-stack)))))) + (else + (let + ((cur-val (get (get (get interp :frame) :locals) name))) + (if + (and (not (nil? cur-val)) (upvar-alias? cur-val)) + ; set in target frame + (let + ((target-level (get cur-val :upvar-level)) + (target-name (get cur-val :upvar-name))) (let - ((updated-target (frame-set-top target-frame target-name val))) + ((full-stack (tcl-full-stack interp))) (let - ((new-full-stack (replace-at full-stack target-level updated-target))) + ((target-frame (tcl-frame-nth full-stack target-level))) (let - ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1))) - (new-current (nth new-full-stack (- (len new-full-stack) 1)))) - (assoc interp :frame new-current :frame-stack new-frame-stack))))))) - ; normal set in current frame top - (assoc interp :frame (frame-set-top (get interp :frame) name val)))))) + ((updated-target (frame-set-top target-frame target-name val))) + (let + ((new-full-stack (replace-at full-stack target-level updated-target))) + (let + ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1))) + (new-current (nth new-full-stack (- (len new-full-stack) 1)))) + (assoc interp :frame new-current :frame-stack new-frame-stack))))))) + ; normal set in current frame top + (assoc interp :frame (frame-set-top (get interp :frame) name val)))))))) (define tcl-eval-parts @@ -292,15 +339,20 @@ (> (len result-stack) caller-stack-len) (nth result-stack caller-stack-len) (get interp :frame)))) - ; 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 + ; Forward state that must escape the proc body — + ; :commands, :procs, :fileevents, :timers. Without this + ; fileevent registrations made inside a proc body are + ; lost on return (broke socket -async accept handlers). + (assoc interp :frame updated-caller :frame-stack updated-below :result result-val :output (str caller-output proc-output) - :code (if (= code 2) 0 code)))))))))))))) + :code (if (= code 2) 0 code) + :commands (get result-interp :commands) + :procs (get result-interp :procs) + :fileevents (get result-interp :fileevents) + :timers (get result-interp :timers)))))))))))))) (define tcl-eval-cmd @@ -1214,6 +1266,7 @@ (tcl-fmt-scan-num chars (+ j 1) (str acc-n ch)) {:num acc-n :j j}))))) +; Walk format string char by char; dispatch each %spec to printf-spec. (define tcl-fmt-apply (fn @@ -1237,50 +1290,30 @@ (if (>= i2 n-len) (str acc "%") - (let - ((c2 (nth chars i2))) - (if - (equal? c2 "%") - (tcl-fmt-apply - chars - n-len - fmt-args - (+ i2 1) - arg-idx - (str acc "%")) - (let - ((fr (tcl-fmt-scan-flags chars i2 ""))) + (if + (equal? (nth chars i2) "%") + ; literal %% + (tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%")) + ; dispatch via printf-spec + (let + ((j (tcl-fmt-find-end chars i2 n-len))) + (if + (>= j n-len) + (str acc "?") (let - ((flags (get fr :flags)) (j (get fr :j))) - (let - ((wr (tcl-fmt-scan-num chars j ""))) - (let - ((width (get wr :num)) (j2 (get wr :j))) - (let - ((j3 (if (and (< j2 n-len) (equal? (nth chars j2) ".")) (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) j2))) - (if - (>= j3 n-len) - (str acc "?") - (let - ((type-char (nth chars j3)) - (cur-arg - (if - (< arg-idx (len fmt-args)) - (nth fmt-args arg-idx) - ""))) - (let - ((zero-pad? (contains? (split flags "") "0")) - (left-align? - (contains? (split flags "") "-"))) - (let - ((formatted (cond ((or (equal? type-char "d") (equal? type-char "i")) (tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?)) ((equal? type-char "s") (tcl-fmt-pad cur-arg width false left-align?)) ((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e")) cur-arg) ((equal? type-char "x") (str (parse-int cur-arg))) ((equal? type-char "o") (str (parse-int cur-arg))) ((equal? type-char "c") cur-arg) (else (str "%" type-char))))) - (tcl-fmt-apply - chars - n-len - fmt-args - (+ j3 1) - (+ arg-idx 1) - (str acc formatted)))))))))))))))))))) + ((spec (str "%" (join "" (slice chars i2 (+ j 1))))) + (cur-arg + (if + (< arg-idx (len fmt-args)) + (nth fmt-args arg-idx) + ""))) + (tcl-fmt-apply + chars + n-len + fmt-args + (+ j 1) + (+ arg-idx 1) + (str acc (printf-spec spec cur-arg)))))))))))))) ; --- string command helpers --- @@ -1300,8 +1333,127 @@ interp :result (tcl-fmt-apply chars n-len fmt-args 0 0 ""))))))) -; toupper/tolower via char tables -(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0"))) +; scan str fmt ?varName ...? — printf-style parse. +; Returns count of successful conversions. If varNames given, sets each to +; its conversion result; otherwise returns the values as a list. +(define + tcl-cmd-scan + (fn + (interp args) + (if + (< (len args) 2) + (error "scan: wrong # args") + (let + ((input (first args)) + (fmt (nth args 1)) + (var-names (slice args 2 (len args)))) + (let + ((parsed + (tcl-scan-loop + input + (split fmt "") + (string-length fmt) + 0 + 0 + (list)))) + (if + (= 0 (len var-names)) + (assoc interp :result (tcl-list-build parsed)) + (let + ((bind-loop + (fn + (i-interp i) + (if + (>= i (len var-names)) + i-interp + (let + ((v (if (< i (len parsed)) (str (nth parsed i)) ""))) + (bind-loop (tcl-var-set i-interp (nth var-names i) v) (+ i 1))))))) + (let ((bound (bind-loop interp 0))) + (assoc bound :result (str (len parsed))))))))))) + +; Loop helper: walk format chars, dispatch each %spec to scan-spec. +(define + tcl-scan-loop + (fn + (input fmt-chars n-fmt fi pos values) + (if + (>= fi n-fmt) + values + (let + ((c (nth fmt-chars fi))) + (cond + ((equal? c "%") + (if + (>= (+ fi 1) n-fmt) + values + (let + ((j (tcl-fmt-find-end fmt-chars (+ fi 1) n-fmt))) + (if + (>= j n-fmt) + values + (let + ((spec (str "%" (join "" (slice fmt-chars (+ fi 1) (+ j 1))))) + (rem-str (substring input pos (string-length input)))) + (let + ((r (scan-spec spec rem-str))) + (if + (nil? r) + values + (tcl-scan-loop + input + fmt-chars + n-fmt + (+ j 1) + (+ pos (get r :consumed)) + (append values (list (str (get r :value)))))))))))) + ((or (equal? c " ") (equal? c "\t") (equal? c "\n")) + (tcl-scan-loop + input + fmt-chars + n-fmt + (+ fi 1) + (tcl-skip-ws input pos) + values)) + (else + (if + (and + (< pos (string-length input)) + (equal? c (substring input pos (+ pos 1)))) + (tcl-scan-loop input fmt-chars n-fmt (+ fi 1) (+ pos 1) values) + values))))))) + +; Find end of a printf spec starting at fi (after '%'). Returns index of +; the conversion character. +(define + tcl-fmt-find-end + (fn + (chars i n) + (if + (>= i n) + i + (let + ((c (nth chars i))) + (cond + ((or (equal? c "-") (equal? c "+") (equal? c " ") (equal? c "0") (equal? c "#")) + (tcl-fmt-find-end chars (+ i 1) n)) + ((or (equal? c ".") (and (>= c "0") (<= c "9"))) + (tcl-fmt-find-end chars (+ i 1) n)) + (else i)))))) + +(define + tcl-skip-ws + (fn + (input pos) + (if + (>= pos (string-length input)) + pos + (let + ((c (substring input pos (+ pos 1)))) + (if + (or (equal? c " ") (equal? c "\t") (equal? c "\n")) + (tcl-skip-ws input (+ pos 1)) + pos))))) (define tcl-glob-match @@ -2042,6 +2194,123 @@ ((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args))) (assoc interp :result (tcl-list-build all-elems))))) +; lassign list var ?var ...? → assigns elements to vars; returns +; remaining unassigned elements as a list (empty string if all consumed) +(define + tcl-cmd-lassign + (fn + (interp args) + (if + (= 0 (len args)) + (error "lassign: wrong # args") + (let + ((elems (tcl-list-split (first args))) (vars (rest args))) + (let + ((bind-loop + (fn + (i-interp i) + (if + (>= i (len vars)) + i-interp + (let + ((var (nth vars i)) + (val (if (< i (len elems)) (nth elems i) ""))) + (bind-loop (tcl-var-set i-interp var val) (+ i 1))))))) + (let + ((bound (bind-loop interp 0))) + (let + ((leftover + (if + (> (len elems) (len vars)) + (slice elems (len vars) (len elems)) + (list)))) + (assoc bound :result (tcl-list-build leftover))))))))) + +; lrepeat count ?elem ...? → list with elem... repeated count times +(define + tcl-cmd-lrepeat + (fn + (interp args) + (if + (= 0 (len args)) + (error "lrepeat: wrong # args") + (let + ((n (parse-int (first args))) (elems (rest args))) + (if + (or (< n 0) (= 0 (len elems))) + (assoc interp :result "") + (let + ((build + (fn + (i acc) + (if (= i 0) acc (build (- i 1) (append acc elems)))))) + (assoc interp :result (tcl-list-build (build n (list)))))))))) + +; lset varname index value → set element at index in list-valued variable +(define + tcl-cmd-lset + (fn + (interp args) + (if + (< (len args) 3) + (error "lset: wrong # args") + (let + ((varname (first args)) + (idx (parse-int (nth args 1))) + (val (nth args 2))) + (let + ((cur (tcl-var-get interp varname))) + (let + ((elems (tcl-list-split cur))) + (if + (or (< idx 0) (>= idx (len elems))) + (error (str "lset: index out of range " idx)) + (let + ((new-list (replace-at elems idx val))) + (let + ((new-str (tcl-list-build new-list))) + (assoc + (tcl-var-set interp varname new-str) + :result new-str)))))))))) + +; lmap helper: like foreach-loop but collects body results +(define + tcl-lmap-loop + (fn + (interp varname items body acc) + (if + (= 0 (len items)) + (assoc interp :result (tcl-list-build acc)) + (let + ((body-result (tcl-eval-string (tcl-var-set interp varname (first items)) body))) + (let + ((code (get body-result :code))) + (cond + ((= code 3) (assoc (assoc body-result :code 0) :result (tcl-list-build acc))) + ((= code 4) (tcl-lmap-loop (assoc body-result :code 0) varname (rest items) body acc)) + ((= code 2) body-result) + ((= code 1) body-result) + (else + (tcl-lmap-loop + (assoc body-result :code 0) + varname + (rest items) + body + (append acc (list (get body-result :result))))))))))) + +(define + tcl-cmd-lmap + (fn + (interp args) + (if + (< (len args) 3) + (error "lmap: wrong # args") + (let + ((varname (first args)) + (list-str (nth args 1)) + (body (nth args 2))) + (tcl-lmap-loop interp varname (tcl-list-split list-str) body (list)))))) + ; --- dict command helpers --- ; Parse flat dict string into SX list of [key val] pairs @@ -2316,6 +2585,51 @@ (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) + ((equal? sub "lappend") + ; dict lappend dictVarName key elem ?elem ...? + (let + ((varname (first rest-args)) + (key (nth rest-args 1)) + (new-elems (slice rest-args 2 (len rest-args)))) + (let + ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v)))) + (let + ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v)))) + (let + ((merged (tcl-list-build (append (tcl-list-split old-val) new-elems)))) + (let + ((new-dict (tcl-dict-set-pair cur key merged))) + (assoc + (tcl-var-set interp varname new-dict) + :result new-dict))))))) + ((equal? sub "remove") + ; dict remove dict ?key ...? + (let + ((dict-str (first rest-args)) + (keys-to-remove (rest rest-args))) + (assoc + interp + :result (reduce + (fn (acc k) (tcl-dict-unset-key acc k)) + dict-str + keys-to-remove)))) + ((equal? sub "filter") + ; dict filter dict key pattern — only `key` filter supported + (let + ((dict-str (first rest-args)) + (mode (nth rest-args 1)) + (pattern (nth rest-args 2))) + (if + (not (equal? mode "key")) + (error (str "dict filter: only key filter implemented, got " mode)) + (let + ((kept + (filter + (fn (pair) (tcl-glob-match (split pattern "") (split (first pair) ""))) + (tcl-dict-to-pairs dict-str)))) + (assoc + interp + :result (tcl-dict-from-pairs kept)))))) (else (error (str "dict: unknown subcommand \"" sub "\"")))))))) ; Qualify a proc name relative to current-ns. @@ -2782,7 +3096,7 @@ (let ((varname (first rest-args))) (let - ((val (frame-lookup (get interp :frame) varname))) + ((val (tcl-var-lookup-or-nil interp varname))) (assoc interp :result (if (nil? val) "0" "1"))))) ((equal? sub "hostname") (assoc interp :result "localhost")) ((equal? sub "script") (assoc interp :result "")) @@ -3011,6 +3325,13 @@ (fn (interp args) (let ((_ (channel-flush (first args)))) (assoc interp :result "")))) + +; exec cmd ?arg ...? — run external process, return stdout (newline-stripped) +(define + tcl-cmd-exec + (fn + (interp args) + (assoc interp :result (exec-process args)))) (define tcl-cmd-fconfigure (fn @@ -3223,6 +3544,22 @@ (tcl-event-step interp (- target-ms now)) target-ms))))) +; Look up a Tcl var by name, returning nil instead of erroring if missing. +; Handles `::var` global-prefix routing the same way tcl-var-get does. +(define + tcl-var-lookup-or-nil + (fn + (interp name) + (if + (tcl-global-ref? name) + (let + ((root-frame + (let ((stack (get interp :frame-stack))) + (if (= 0 (len stack)) (get interp :frame) (first stack)))) + (gname (tcl-strip-global name))) + (frame-lookup root-frame gname)) + (frame-lookup (get interp :frame) name)))) + (define tcl-cmd-vwait (fn @@ -3233,7 +3570,7 @@ (let ((name (first args))) (let - ((initial (frame-lookup (get interp :frame) name))) + ((initial (tcl-var-lookup-or-nil interp name))) (assoc (tcl-vwait-loop interp name initial) :result "")))))) (define @@ -3241,7 +3578,7 @@ (fn (interp name initial) (let - ((cur (frame-lookup (get interp :frame) name))) + ((cur (tcl-var-lookup-or-nil interp name))) (if (and (not (nil? cur)) (not (equal? cur initial))) interp @@ -3783,6 +4120,16 @@ ((i (tcl-register i "linsert" tcl-cmd-linsert))) (let ((i (tcl-register i "concat" tcl-cmd-concat))) + (let + ((i (tcl-register i "lassign" tcl-cmd-lassign))) + (let + ((i (tcl-register i "lrepeat" tcl-cmd-lrepeat))) + (let + ((i (tcl-register i "lset" tcl-cmd-lset))) + (let + ((i (tcl-register i "lmap" tcl-cmd-lmap))) + (let + ((i (tcl-register i "exec" tcl-cmd-exec))) (let ((i (tcl-register i "split" tcl-cmd-split))) (let @@ -3856,4 +4203,4 @@ (tcl-register i "array" - tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/test.sh b/lib/tcl/test.sh index fb24a662..e42fbfa2 100755 --- a/lib/tcl/test.sh +++ b/lib/tcl/test.sh @@ -59,7 +59,7 @@ cat > "$TMPFILE" << EPOCHS (eval "tcl-test-summary") EPOCHS -OUTPUT=$(timeout 2400 "$SX_SERVER" < "$TMPFILE" 2>&1) +OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1) [ "$VERBOSE" = "-v" ] && echo "$OUTPUT" # Extract summary line from epoch 11 output diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index b6df6180..7b8e1160 100644 --- a/lib/tcl/tests/idioms.sx +++ b/lib/tcl/tests/idioms.sx @@ -415,6 +415,115 @@ :result) "") + ; 60-63. Phase 6a namespace :: prefix + (ok "ns-set-from-proc-reaches-global" + (get + (run + "proc f {x} { set ::g $x }\nf hello\nset ::g") + :result) + "hello") + + (ok "ns-read-from-proc" + (get + (run + "set ::v 42\nproc f {} { return $::v }\nf") + :result) + "42") + + (ok "ns-incr-via-prefix" + (get + (run + "set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n") + :result) + "7") + + (ok "ns-different-from-local" + (get + (run + "set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf") + :result) + "inner") + + ; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap) + (ok "lassign-three" + (get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result) + "a b c") + + (ok "lassign-leftover" + (get (run "lassign {1 2 3 4 5} a b") :result) + "3 4 5") + + (ok "lrepeat-basic" + (get (run "lrepeat 3 a") :result) + "a a a") + + (ok "lrepeat-multi" + (get (run "lrepeat 2 x y") :result) + "x y x y") + + (ok "lset-replaces" + (get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result) + "a b ZZ d") + + (ok "lmap-square" + (get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result) + "1 4 9 16") + + ; 70-72. Phase 6c dict additions (lappend, remove, filter) + (ok "dict-lappend-extends" + (get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result) + "tags {a b c d}") + + (ok "dict-remove" + (get (run "dict remove {a 1 b 2 c 3} b") :result) + "a 1 c 3") + + (ok "dict-filter-key" + (get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result) + "alpha 1") + + ; 73-79. Phase 6d format and scan + (ok "format-int-padded" + (get (run "format {%05d} 42") :result) + "00042") + + (ok "format-float-precision" + (get (run "format {%.2f} 3.14159") :result) + "3.14") + + (ok "format-hex" + (get (run "format {%x} 255") :result) + "ff") + + (ok "format-char" + (get (run "format {%c} 65") :result) + "A") + + (ok "format-string-left" + (get (run "format {%-5s|} hi") :result) + "hi |") + + (ok "scan-two-ints" + (get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result) + "12 34") + + (ok "scan-count" + (get (run "scan {hello 42} {%s %d}") :result) + "hello 42") + + ; 80-82. Phase 6e exec + (ok "exec-echo" + (get (run "exec echo hello world") :result) + "hello world") + + (ok "exec-printf-no-newline" + (get (run "exec /bin/printf x") :result) + "x") + + (ok "exec-with-args" + (get (run "exec /bin/echo -n test") :result) + "test") + (dict "passed" tcl-idiom-pass diff --git a/lib/tcl/tokenizer.sx b/lib/tcl/tokenizer.sx index bc094ff3..d95135bf 100644 --- a/lib/tcl/tokenizer.sx +++ b/lib/tcl/tokenizer.sx @@ -158,7 +158,9 @@ (begin (when (= (cur) "}") (advance! 1)) {:type "var" :name name})))))) - ((tcl-ident-start? (cur)) + ((or + (tcl-ident-start? (cur)) + (and (= (cur) ":") (= (char-at 1) ":"))) (let ((start pos)) (begin (scan-ns-name!)