Compare commits
5 Commits
2defa5e739
...
loops/tcl
| Author | SHA1 | Date | |
|---|---|---|---|
| 50b69bcbd0 | |||
| 14986d787d | |||
| 21028c4fb0 | |||
| 7415dd020e | |||
| 2fa0bb4df1 |
@@ -528,6 +528,183 @@ let () =
|
|||||||
| [Rational (_, d)] -> Integer d
|
| [Rational (_, d)] -> Integer d
|
||||||
| [Integer _] -> Integer 1
|
| [Integer _] -> Integer 1
|
||||||
| _ -> raise (Eval_error "denominator: expected rational or integer"));
|
| _ -> 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 ->
|
register "parse-int" (fun args ->
|
||||||
let parse_leading_int s =
|
let parse_leading_int s =
|
||||||
let len = String.length s in
|
let len = String.length s in
|
||||||
@@ -3366,6 +3543,204 @@ let () =
|
|||||||
Nil
|
Nil
|
||||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
| _ -> 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);
|
||||||
|
|
||||||
|
(* exec-pipeline: takes a list of words like Tcl `exec` would receive.
|
||||||
|
Recognizes `|` as a stage separator and `> file`, `>> file`, `< file`,
|
||||||
|
`2>@1` (stderr→stdout), `2> file`. Returns trimmed stdout of the last
|
||||||
|
stage; raises Eval_error if the last stage exits non-zero. *)
|
||||||
|
register "exec-pipeline" (fun args ->
|
||||||
|
let items = match args with
|
||||||
|
| [List xs] | [ListRef { contents = xs }] -> xs
|
||||||
|
| _ -> raise (Eval_error "exec-pipeline: (word-list)")
|
||||||
|
in
|
||||||
|
let words = List.map (function
|
||||||
|
| String s -> s
|
||||||
|
| v -> Sx_types.inspect v
|
||||||
|
) items in
|
||||||
|
if words = [] then raise (Eval_error "exec: empty command");
|
||||||
|
let split_stages ws =
|
||||||
|
let rec loop acc cur = function
|
||||||
|
| [] -> List.rev (List.rev cur :: acc)
|
||||||
|
| "|" :: rest -> loop (List.rev cur :: acc) [] rest
|
||||||
|
| w :: rest -> loop acc (w :: cur) rest
|
||||||
|
in
|
||||||
|
loop [] [] ws
|
||||||
|
in
|
||||||
|
let extract_redirs ws =
|
||||||
|
let in_path = ref None in
|
||||||
|
let out_path = ref None in
|
||||||
|
let out_append = ref false in
|
||||||
|
let err_path = ref None in
|
||||||
|
let merge_err = ref false in
|
||||||
|
let cleaned = ref [] in
|
||||||
|
let rec loop = function
|
||||||
|
| [] -> ()
|
||||||
|
| "<" :: p :: rest -> in_path := Some p; loop rest
|
||||||
|
| ">" :: p :: rest -> out_path := Some p; out_append := false; loop rest
|
||||||
|
| ">>" :: p :: rest -> out_path := Some p; out_append := true; loop rest
|
||||||
|
| "2>@1" :: rest -> merge_err := true; loop rest
|
||||||
|
| "2>" :: p :: rest -> err_path := Some p; loop rest
|
||||||
|
| w :: rest -> cleaned := w :: !cleaned; loop rest
|
||||||
|
in
|
||||||
|
loop ws;
|
||||||
|
(List.rev !cleaned, !in_path, !out_path, !out_append, !err_path, !merge_err)
|
||||||
|
in
|
||||||
|
let stages = List.map extract_redirs (split_stages words) in
|
||||||
|
if stages = [] then raise (Eval_error "exec: no stages");
|
||||||
|
let n = List.length stages in
|
||||||
|
let pipes = Array.init (max 0 (n - 1)) (fun _ -> Unix.pipe ()) in
|
||||||
|
let (final_r, final_w) = Unix.pipe () in
|
||||||
|
let (errstash_r, errstash_w) = Unix.pipe () in
|
||||||
|
let pids = ref [] in
|
||||||
|
let close_safe fd = try Unix.close fd with _ -> () in
|
||||||
|
let open_in_redir = function
|
||||||
|
| None -> Unix.stdin
|
||||||
|
| Some path ->
|
||||||
|
(try Unix.openfile path [Unix.O_RDONLY] 0o644
|
||||||
|
with Unix.Unix_error (e, _, _) ->
|
||||||
|
raise (Eval_error ("exec: open <" ^ path ^ ": " ^ Unix.error_message e)))
|
||||||
|
in
|
||||||
|
let open_out_redir path append =
|
||||||
|
let flags = Unix.O_WRONLY :: Unix.O_CREAT :: (if append then [Unix.O_APPEND] else [Unix.O_TRUNC]) in
|
||||||
|
try Unix.openfile path flags 0o644
|
||||||
|
with Unix.Unix_error (e, _, _) ->
|
||||||
|
raise (Eval_error ("exec: open >" ^ path ^ ": " ^ Unix.error_message e))
|
||||||
|
in
|
||||||
|
let stages_arr = Array.of_list stages in
|
||||||
|
(try
|
||||||
|
Array.iteri (fun i (cleaned, ip, op, app, ep, merge) ->
|
||||||
|
if cleaned = [] then raise (Eval_error "exec: empty stage in pipeline");
|
||||||
|
let argv = Array.of_list cleaned in
|
||||||
|
let stdin_fd =
|
||||||
|
if i = 0 then open_in_redir ip
|
||||||
|
else fst pipes.(i - 1)
|
||||||
|
in
|
||||||
|
let stdout_fd =
|
||||||
|
if i = n - 1 then
|
||||||
|
(match op with
|
||||||
|
| None -> final_w
|
||||||
|
| Some path -> open_out_redir path app)
|
||||||
|
else snd pipes.(i)
|
||||||
|
in
|
||||||
|
let stderr_fd =
|
||||||
|
if merge then stdout_fd
|
||||||
|
else (match ep with
|
||||||
|
| None -> if i = n - 1 then errstash_w else Unix.stderr
|
||||||
|
| Some path -> open_out_redir path false)
|
||||||
|
in
|
||||||
|
let pid =
|
||||||
|
try Unix.create_process argv.(0) argv stdin_fd stdout_fd stderr_fd
|
||||||
|
with Unix.Unix_error (e, _, _) ->
|
||||||
|
raise (Eval_error ("exec: " ^ argv.(0) ^ ": " ^ Unix.error_message e))
|
||||||
|
in
|
||||||
|
pids := pid :: !pids;
|
||||||
|
if i > 0 then close_safe (fst pipes.(i - 1));
|
||||||
|
if i < n - 1 then close_safe (snd pipes.(i));
|
||||||
|
if i = 0 && ip <> None then close_safe stdin_fd;
|
||||||
|
if i = n - 1 && op <> None then close_safe stdout_fd;
|
||||||
|
if not merge && ep <> None then close_safe stderr_fd
|
||||||
|
) stages_arr
|
||||||
|
with e ->
|
||||||
|
close_safe final_r; close_safe final_w;
|
||||||
|
close_safe errstash_r; close_safe errstash_w;
|
||||||
|
Array.iter (fun (a,b) -> close_safe a; close_safe b) pipes;
|
||||||
|
raise e);
|
||||||
|
close_safe final_w;
|
||||||
|
close_safe errstash_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 r = Unix.read fd chunk 0 (Bytes.length chunk) in
|
||||||
|
if r = 0 then stop := true
|
||||||
|
else Buffer.add_subbytes target chunk 0 r
|
||||||
|
done
|
||||||
|
with _ -> ()
|
||||||
|
in
|
||||||
|
read_all final_r buf;
|
||||||
|
read_all errstash_r errbuf;
|
||||||
|
close_safe final_r;
|
||||||
|
close_safe errstash_r;
|
||||||
|
let exit_codes = List.rev_map (fun pid ->
|
||||||
|
let (_, st) = Unix.waitpid [] pid in
|
||||||
|
match st with
|
||||||
|
| Unix.WEXITED c -> c
|
||||||
|
| _ -> 1
|
||||||
|
) !pids in
|
||||||
|
let final_code = match List.rev exit_codes with
|
||||||
|
| [] -> 0
|
||||||
|
| last :: _ -> last
|
||||||
|
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 final_code <> 0 then
|
||||||
|
raise (Eval_error ("exec: pipeline last stage exited " ^ string_of_int final_code
|
||||||
|
^ (if Buffer.length errbuf > 0
|
||||||
|
then ": " ^ Buffer.contents errbuf
|
||||||
|
else "")))
|
||||||
|
else String trimmed);
|
||||||
|
|
||||||
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
(* === Sockets === wrapping Unix.socket/connect/bind/listen/accept *)
|
||||||
let resolve_inet_addr host =
|
let resolve_inet_addr host =
|
||||||
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
if host = "" || host = "0.0.0.0" then Unix.inet_addr_any
|
||||||
|
|||||||
@@ -73,10 +73,40 @@
|
|||||||
(fn (full-stack level)
|
(fn (full-stack level)
|
||||||
(nth 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
|
(define
|
||||||
tcl-var-get
|
tcl-var-get
|
||||||
(fn
|
(fn
|
||||||
(interp name)
|
(interp name)
|
||||||
|
(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
|
(let
|
||||||
((val (frame-lookup (get interp :frame) name)))
|
((val (frame-lookup (get interp :frame) name)))
|
||||||
(if
|
(if
|
||||||
@@ -98,12 +128,29 @@
|
|||||||
(nil? target-val)
|
(nil? target-val)
|
||||||
(error (str "can't read \"" name "\": no such variable"))
|
(error (str "can't read \"" name "\": no such variable"))
|
||||||
target-val)))))
|
target-val)))))
|
||||||
val)))))
|
val))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
tcl-var-set
|
tcl-var-set
|
||||||
(fn
|
(fn
|
||||||
(interp name val)
|
(interp name val)
|
||||||
|
(cond
|
||||||
|
((tcl-global-ref? name)
|
||||||
|
; absolute reference — set in global (root) frame
|
||||||
|
(let
|
||||||
|
((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
|
||||||
|
((root-frame (first stack))
|
||||||
|
(rest-stack (rest stack)))
|
||||||
|
(assoc
|
||||||
|
interp
|
||||||
|
:frame-stack
|
||||||
|
(cons (frame-set-top root-frame gname val) rest-stack))))))
|
||||||
|
(else
|
||||||
(let
|
(let
|
||||||
((cur-val (get (get (get interp :frame) :locals) name)))
|
((cur-val (get (get (get interp :frame) :locals) name)))
|
||||||
(if
|
(if
|
||||||
@@ -125,7 +172,7 @@
|
|||||||
(new-current (nth 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)))))))
|
(assoc interp :frame new-current :frame-stack new-frame-stack)))))))
|
||||||
; normal set in current frame top
|
; normal set in current frame top
|
||||||
(assoc interp :frame (frame-set-top (get interp :frame) name val))))))
|
(assoc interp :frame (frame-set-top (get interp :frame) name val))))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
tcl-eval-parts
|
tcl-eval-parts
|
||||||
@@ -292,15 +339,20 @@
|
|||||||
(> (len result-stack) caller-stack-len)
|
(> (len result-stack) caller-stack-len)
|
||||||
(nth result-stack caller-stack-len)
|
(nth result-stack caller-stack-len)
|
||||||
(get interp :frame))))
|
(get interp :frame))))
|
||||||
; Forward result-interp as base so state changes inside
|
; Forward state that must escape the proc body —
|
||||||
; the proc (e.g. :fileevents, :timers, :procs) propagate;
|
; :commands, :procs, :fileevents, :timers. Without this
|
||||||
; restore caller's frame/stack/result/output/code.
|
; fileevent registrations made inside a proc body are
|
||||||
(assoc result-interp
|
; lost on return (broke socket -async accept handlers).
|
||||||
|
(assoc interp
|
||||||
:frame updated-caller
|
:frame updated-caller
|
||||||
:frame-stack updated-below
|
:frame-stack updated-below
|
||||||
:result result-val
|
:result result-val
|
||||||
:output (str caller-output proc-output)
|
: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
|
(define
|
||||||
tcl-eval-cmd
|
tcl-eval-cmd
|
||||||
@@ -920,6 +972,15 @@
|
|||||||
((equal? code-str "continue") (= rc 4))
|
((equal? code-str "continue") (= rc 4))
|
||||||
(else (= rc (parse-int code-str))))))
|
(else (= rc (parse-int code-str))))))
|
||||||
|
|
||||||
|
; trap pattern is a list; matches errorcode list if pattern is a prefix.
|
||||||
|
(define tcl-try-trap-matches? (fn (pattern-str errorcode-str rc) (if (not (= rc 1)) false (let ((pat-elems (tcl-list-split pattern-str)) (ec-elems (tcl-list-split errorcode-str))) (if (> (len pat-elems) (len ec-elems)) false (let ((all-eq? (fn (i lim) (if (>= i lim) true (if (equal? (nth pat-elems i) (nth ec-elems i)) (all-eq? (+ i 1) lim) false))))) (all-eq? 0 (len pat-elems))))))))
|
||||||
|
|
||||||
|
; Brace if needs quoting for inclusion in a flat dict string.
|
||||||
|
(define tcl-try-brace-if-needed (fn (s) (if (or (equal? s "") (contains? (split s "") " ")) (str "{" s "}") s)))
|
||||||
|
|
||||||
|
; Build the -options dict that try clause varlist captures as 2nd arg.
|
||||||
|
(define tcl-try-build-opts (fn (rc rei rec) (str "-code " rc " -level 0 -errorcode " (tcl-try-brace-if-needed rec) " -errorinfo " (tcl-try-brace-if-needed rei))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
tcl-cmd-try
|
tcl-cmd-try
|
||||||
(fn
|
(fn
|
||||||
@@ -927,7 +988,7 @@
|
|||||||
(let
|
(let
|
||||||
((script (first args)) (rest-args (rest args)))
|
((script (first args)) (rest-args (rest args)))
|
||||||
(let
|
(let
|
||||||
((parse-clauses (fn (remaining acc) (if (= 0 (len remaining)) acc (let ((kw (first remaining))) (cond ((equal? kw "on") (if (< (len remaining) 4) acc (parse-clauses (slice remaining 4 (len remaining)) (append acc (list {:body (nth remaining 3) :code (nth remaining 1) :type "on" :var (nth remaining 2)}))))) ((equal? kw "finally") (if (< (len remaining) 2) acc (parse-clauses (slice remaining 2 (len remaining)) (append acc (list {:body (nth remaining 1) :type "finally"}))))) (else acc))))))
|
((parse-clauses (fn (remaining acc) (if (= 0 (len remaining)) acc (let ((kw (first remaining))) (cond ((equal? kw "on") (if (< (len remaining) 4) acc (parse-clauses (slice remaining 4 (len remaining)) (append acc (list {:body (nth remaining 3) :code (nth remaining 1) :type "on" :var (nth remaining 2)}))))) ((equal? kw "trap") (if (< (len remaining) 4) acc (parse-clauses (slice remaining 4 (len remaining)) (append acc (list {:body (nth remaining 3) :pattern (nth remaining 1) :type "trap" :var (nth remaining 2)}))))) ((equal? kw "finally") (if (< (len remaining) 2) acc (parse-clauses (slice remaining 2 (len remaining)) (append acc (list {:body (nth remaining 1) :type "finally"}))))) (else acc))))))
|
||||||
(clauses (parse-clauses rest-args (list))))
|
(clauses (parse-clauses rest-args (list))))
|
||||||
(let
|
(let
|
||||||
((sub-interp (assoc interp :code 0 :result ""))
|
((sub-interp (assoc interp :code 0 :result ""))
|
||||||
@@ -937,9 +998,11 @@
|
|||||||
(let
|
(let
|
||||||
((rc (get result-interp :code))
|
((rc (get result-interp :code))
|
||||||
(rv (get result-interp :result))
|
(rv (get result-interp :result))
|
||||||
|
(rei (get result-interp :errorinfo))
|
||||||
|
(rec (get result-interp :errorcode))
|
||||||
(sub-output (get result-interp :output)))
|
(sub-output (get result-interp :output)))
|
||||||
(let
|
(let
|
||||||
((find-clause (fn (cs) (if (= 0 (len cs)) nil (let ((c (first cs))) (if (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) c (find-clause (rest cs)))))))
|
((find-clause (fn (cs) (if (= 0 (len cs)) nil (let ((c (first cs))) (cond ((and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) c) ((and (equal? (get c :type) "trap") (tcl-try-trap-matches? (get c :pattern) rec rc)) c) (else (find-clause (rest cs))))))))
|
||||||
(matched (find-clause clauses))
|
(matched (find-clause clauses))
|
||||||
(finally-clause
|
(finally-clause
|
||||||
(reduce
|
(reduce
|
||||||
@@ -949,7 +1012,7 @@
|
|||||||
nil
|
nil
|
||||||
clauses)))
|
clauses)))
|
||||||
(let
|
(let
|
||||||
((after-handler (if (nil? matched) (assoc result-interp :output (str caller-output sub-output)) (let ((handler-interp (assoc result-interp :code 0 :output (str caller-output sub-output)))) (let ((bound-interp (if (equal? (get matched :var) "") handler-interp (tcl-var-set handler-interp (get matched :var) rv)))) (tcl-eval-string bound-interp (get matched :body)))))))
|
((after-handler (if (nil? matched) (assoc result-interp :output (str caller-output sub-output)) (let ((handler-interp (assoc result-interp :code 0 :output (str caller-output sub-output))) (vars (tcl-list-split (get matched :var)))) (let ((bound1 (if (>= (len vars) 1) (tcl-var-set handler-interp (first vars) rv) handler-interp))) (let ((bound2 (if (>= (len vars) 2) (tcl-var-set bound1 (nth vars 1) (tcl-try-build-opts rc rei rec)) bound1))) (tcl-eval-string bound2 (get matched :body))))))))
|
||||||
(let
|
(let
|
||||||
((final-result (if (nil? finally-clause) after-handler (let ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) (if (= (get fi :code) 0) (assoc fi :code (get after-handler :code) :result (get after-handler :result)) fi)))))
|
((final-result (if (nil? finally-clause) after-handler (let ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) (if (= (get fi :code) 0) (assoc fi :code (get after-handler :code) :result (get after-handler :result)) fi)))))
|
||||||
final-result))))))))))
|
final-result))))))))))
|
||||||
@@ -1214,6 +1277,7 @@
|
|||||||
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
|
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
|
||||||
{:num acc-n :j j})))))
|
{:num acc-n :j j})))))
|
||||||
|
|
||||||
|
; Walk format string char by char; dispatch each %spec to printf-spec.
|
||||||
(define
|
(define
|
||||||
tcl-fmt-apply
|
tcl-fmt-apply
|
||||||
(fn
|
(fn
|
||||||
@@ -1237,50 +1301,30 @@
|
|||||||
(if
|
(if
|
||||||
(>= i2 n-len)
|
(>= i2 n-len)
|
||||||
(str acc "%")
|
(str acc "%")
|
||||||
(let
|
|
||||||
((c2 (nth chars i2)))
|
|
||||||
(if
|
(if
|
||||||
(equal? c2 "%")
|
(equal? (nth chars i2) "%")
|
||||||
(tcl-fmt-apply
|
; literal %%
|
||||||
chars
|
(tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%"))
|
||||||
n-len
|
; dispatch via printf-spec
|
||||||
fmt-args
|
|
||||||
(+ i2 1)
|
|
||||||
arg-idx
|
|
||||||
(str acc "%"))
|
|
||||||
(let
|
(let
|
||||||
((fr (tcl-fmt-scan-flags chars i2 "")))
|
((j (tcl-fmt-find-end chars i2 n-len)))
|
||||||
(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
|
(if
|
||||||
(>= j3 n-len)
|
(>= j n-len)
|
||||||
(str acc "?")
|
(str acc "?")
|
||||||
(let
|
(let
|
||||||
((type-char (nth chars j3))
|
((spec (str "%" (join "" (slice chars i2 (+ j 1)))))
|
||||||
(cur-arg
|
(cur-arg
|
||||||
(if
|
(if
|
||||||
(< arg-idx (len fmt-args))
|
(< arg-idx (len fmt-args))
|
||||||
(nth fmt-args arg-idx)
|
(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
|
(tcl-fmt-apply
|
||||||
chars
|
chars
|
||||||
n-len
|
n-len
|
||||||
fmt-args
|
fmt-args
|
||||||
(+ j3 1)
|
(+ j 1)
|
||||||
(+ arg-idx 1)
|
(+ arg-idx 1)
|
||||||
(str acc formatted))))))))))))))))))))
|
(str acc (printf-spec spec cur-arg))))))))))))))
|
||||||
|
|
||||||
; --- string command helpers ---
|
; --- string command helpers ---
|
||||||
|
|
||||||
@@ -1300,8 +1344,127 @@
|
|||||||
interp
|
interp
|
||||||
:result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))
|
:result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))
|
||||||
|
|
||||||
; toupper/tolower via char tables
|
; scan str fmt ?varName ...? — printf-style parse.
|
||||||
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
|
; 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
|
(define
|
||||||
tcl-glob-match
|
tcl-glob-match
|
||||||
@@ -1654,6 +1817,46 @@
|
|||||||
(equal? s "off"))
|
(equal? s "off"))
|
||||||
"1"
|
"1"
|
||||||
"0"))
|
"0"))
|
||||||
|
((equal? class "true")
|
||||||
|
(if
|
||||||
|
(or (equal? s "1") (equal? s "true") (equal? s "yes") (equal? s "on"))
|
||||||
|
"1"
|
||||||
|
"0"))
|
||||||
|
((equal? class "false")
|
||||||
|
(if
|
||||||
|
(or (equal? s "0") (equal? s "false") (equal? s "no") (equal? s "off"))
|
||||||
|
"1"
|
||||||
|
"0"))
|
||||||
|
((equal? class "xdigit")
|
||||||
|
(if
|
||||||
|
(= n 0)
|
||||||
|
"0"
|
||||||
|
(if
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(ok c)
|
||||||
|
(and
|
||||||
|
ok
|
||||||
|
(or
|
||||||
|
(tcl-expr-digit? c)
|
||||||
|
(or
|
||||||
|
(and (>= c "a") (<= c "f"))
|
||||||
|
(and (>= c "A") (<= c "F"))))))
|
||||||
|
true
|
||||||
|
chars)
|
||||||
|
"1"
|
||||||
|
"0")))
|
||||||
|
((equal? class "ascii")
|
||||||
|
(if
|
||||||
|
(= n 0)
|
||||||
|
"1"
|
||||||
|
(if
|
||||||
|
(reduce
|
||||||
|
(fn (ok c) (and ok (and (>= c " ") (<= c "~"))))
|
||||||
|
true
|
||||||
|
chars)
|
||||||
|
"1"
|
||||||
|
"0")))
|
||||||
(else "0")))))
|
(else "0")))))
|
||||||
|
|
||||||
; Build a Tcl list string from an SX list of string elements
|
; Build a Tcl list string from an SX list of string elements
|
||||||
@@ -1796,6 +1999,66 @@
|
|||||||
((class (first rest-args)) (s (nth rest-args 1)))
|
((class (first rest-args)) (s (nth rest-args 1)))
|
||||||
(assoc interp :result (tcl-string-is class s))))
|
(assoc interp :result (tcl-string-is class s))))
|
||||||
((equal? sub "cat") (assoc interp :result (join "" rest-args)))
|
((equal? sub "cat") (assoc interp :result (join "" rest-args)))
|
||||||
|
((equal? sub "equal")
|
||||||
|
; string equal ?-nocase? ?-length n? s1 s2
|
||||||
|
(let
|
||||||
|
((nocase?
|
||||||
|
(reduce (fn (a w) (or a (equal? w "-nocase"))) false rest-args))
|
||||||
|
(length-pos
|
||||||
|
(let ((find-loop (fn (i) (cond ((>= i (- (len rest-args) 1)) -1) ((equal? (nth rest-args i) "-length") i) (else (find-loop (+ i 1))))))) (find-loop 0)))
|
||||||
|
(cleaned (filter (fn (w) (not (equal? w "-nocase"))) rest-args)))
|
||||||
|
(let
|
||||||
|
((cleaned2
|
||||||
|
(if
|
||||||
|
(>= length-pos 0)
|
||||||
|
(filter
|
||||||
|
(fn (w) (and (not (equal? w "-length")) (not (equal? w (nth rest-args (+ length-pos 1))))))
|
||||||
|
cleaned)
|
||||||
|
cleaned)))
|
||||||
|
(if
|
||||||
|
(< (len cleaned2) 2)
|
||||||
|
(error "string equal: wrong # args")
|
||||||
|
(let
|
||||||
|
((s1 (first cleaned2)) (s2 (nth cleaned2 1)))
|
||||||
|
(let
|
||||||
|
((c1 (if nocase? (join "" (map tcl-downcase-char (split s1 ""))) s1))
|
||||||
|
(c2 (if nocase? (join "" (map tcl-downcase-char (split s2 ""))) s2)))
|
||||||
|
(assoc interp :result (if (equal? c1 c2) "1" "0"))))))))
|
||||||
|
((equal? sub "totitle")
|
||||||
|
(let
|
||||||
|
((s (first rest-args)))
|
||||||
|
(let
|
||||||
|
((chars (split s "")))
|
||||||
|
(assoc
|
||||||
|
interp
|
||||||
|
:result (if
|
||||||
|
(= 0 (len chars))
|
||||||
|
""
|
||||||
|
(str
|
||||||
|
(tcl-upcase-char (first chars))
|
||||||
|
(join "" (map tcl-downcase-char (rest chars)))))))))
|
||||||
|
((equal? sub "reverse")
|
||||||
|
(let
|
||||||
|
((s (first rest-args)))
|
||||||
|
(assoc interp :result (join "" (reverse (split s ""))))))
|
||||||
|
((equal? sub "replace")
|
||||||
|
; string replace s first last ?newstring?
|
||||||
|
(let
|
||||||
|
((s (first rest-args))
|
||||||
|
(n (string-length (first rest-args)))
|
||||||
|
(fi (parse-int (nth rest-args 1)))
|
||||||
|
(li (parse-int (nth rest-args 2)))
|
||||||
|
(newstr (if (> (len rest-args) 3) (nth rest-args 3) "")))
|
||||||
|
(let
|
||||||
|
((f (if (< fi 0) 0 fi))
|
||||||
|
(l (if (>= li n) (- n 1) li)))
|
||||||
|
(if
|
||||||
|
(or (> f l) (>= f n))
|
||||||
|
(assoc interp :result s)
|
||||||
|
(let
|
||||||
|
((before (substring s 0 f))
|
||||||
|
(after (substring s (+ l 1) n)))
|
||||||
|
(assoc interp :result (str before newstr after)))))))
|
||||||
(else (error (str "string: unknown subcommand: " sub))))))))
|
(else (error (str "string: unknown subcommand: " sub))))))))
|
||||||
|
|
||||||
; Resolve "end" index to numeric value given list length
|
; Resolve "end" index to numeric value given list length
|
||||||
@@ -2042,6 +2305,123 @@
|
|||||||
((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args)))
|
((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args)))
|
||||||
(assoc interp :result (tcl-list-build all-elems)))))
|
(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 ---
|
; --- dict command helpers ---
|
||||||
|
|
||||||
; Parse flat dict string into SX list of [key val] pairs
|
; Parse flat dict string into SX list of [key val] pairs
|
||||||
@@ -2316,6 +2696,51 @@
|
|||||||
(assoc
|
(assoc
|
||||||
(tcl-var-set interp varname new-dict)
|
(tcl-var-set interp varname new-dict)
|
||||||
:result 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 "\""))))))))
|
(else (error (str "dict: unknown subcommand \"" sub "\""))))))))
|
||||||
|
|
||||||
; Qualify a proc name relative to current-ns.
|
; Qualify a proc name relative to current-ns.
|
||||||
@@ -2782,7 +3207,7 @@
|
|||||||
(let
|
(let
|
||||||
((varname (first rest-args)))
|
((varname (first rest-args)))
|
||||||
(let
|
(let
|
||||||
((val (frame-lookup (get interp :frame) varname)))
|
((val (tcl-var-lookup-or-nil interp varname)))
|
||||||
(assoc interp :result (if (nil? val) "0" "1")))))
|
(assoc interp :result (if (nil? val) "0" "1")))))
|
||||||
((equal? sub "hostname") (assoc interp :result "localhost"))
|
((equal? sub "hostname") (assoc interp :result "localhost"))
|
||||||
((equal? sub "script") (assoc interp :result ""))
|
((equal? sub "script") (assoc interp :result ""))
|
||||||
@@ -3011,6 +3436,38 @@
|
|||||||
(fn
|
(fn
|
||||||
(interp args)
|
(interp args)
|
||||||
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
|
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
|
||||||
|
|
||||||
|
; exec cmd ?arg ...? ?| cmd2 arg ...? ?> file? ?< file? ?2>@1?
|
||||||
|
; Runs external process(es), returns stdout. Pipelines via |, stdout
|
||||||
|
; redirection >/>>, stdin redirection <, stderr-to-stdout via 2>@1,
|
||||||
|
; stderr redirection 2> file. Routes through exec-pipeline if any
|
||||||
|
; shell metacharacter is present, else exec-process.
|
||||||
|
(define
|
||||||
|
tcl-cmd-exec
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(let
|
||||||
|
((has-pipeline?
|
||||||
|
(reduce
|
||||||
|
(fn
|
||||||
|
(acc w)
|
||||||
|
(or
|
||||||
|
acc
|
||||||
|
(or
|
||||||
|
(equal? w "|")
|
||||||
|
(or
|
||||||
|
(equal? w ">")
|
||||||
|
(or
|
||||||
|
(equal? w ">>")
|
||||||
|
(or
|
||||||
|
(equal? w "<")
|
||||||
|
(or (equal? w "2>") (equal? w "2>@1"))))))))
|
||||||
|
false
|
||||||
|
args)))
|
||||||
|
(assoc
|
||||||
|
interp
|
||||||
|
:result
|
||||||
|
(if has-pipeline? (exec-pipeline args) (exec-process args))))))
|
||||||
(define
|
(define
|
||||||
tcl-cmd-fconfigure
|
tcl-cmd-fconfigure
|
||||||
(fn
|
(fn
|
||||||
@@ -3223,6 +3680,22 @@
|
|||||||
(tcl-event-step interp (- target-ms now))
|
(tcl-event-step interp (- target-ms now))
|
||||||
target-ms)))))
|
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
|
(define
|
||||||
tcl-cmd-vwait
|
tcl-cmd-vwait
|
||||||
(fn
|
(fn
|
||||||
@@ -3233,7 +3706,7 @@
|
|||||||
(let
|
(let
|
||||||
((name (first args)))
|
((name (first args)))
|
||||||
(let
|
(let
|
||||||
((initial (frame-lookup (get interp :frame) name)))
|
((initial (tcl-var-lookup-or-nil interp name)))
|
||||||
(assoc (tcl-vwait-loop interp name initial) :result ""))))))
|
(assoc (tcl-vwait-loop interp name initial) :result ""))))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
@@ -3241,7 +3714,7 @@
|
|||||||
(fn
|
(fn
|
||||||
(interp name initial)
|
(interp name initial)
|
||||||
(let
|
(let
|
||||||
((cur (frame-lookup (get interp :frame) name)))
|
((cur (tcl-var-lookup-or-nil interp name)))
|
||||||
(if
|
(if
|
||||||
(and (not (nil? cur)) (not (equal? cur initial)))
|
(and (not (nil? cur)) (not (equal? cur initial)))
|
||||||
interp
|
interp
|
||||||
@@ -3253,6 +3726,246 @@
|
|||||||
(interp args)
|
(interp args)
|
||||||
(assoc (tcl-event-step interp 0) :result "")))
|
(assoc (tcl-event-step interp 0) :result "")))
|
||||||
|
|
||||||
|
; ============================================================
|
||||||
|
; TclOO — minimal oo::class / oo::object (Phase 7d)
|
||||||
|
; ============================================================
|
||||||
|
|
||||||
|
; Class storage: interp :classes is a dict {name: class-record}
|
||||||
|
; class-record: {:methods (dict name => {:args :body}) :ctor :dtor :super}
|
||||||
|
; Object storage: interp :oo-objects is a dict {objname: {:class :slots}}
|
||||||
|
; Counter: interp :oo-counter — int for unique object names.
|
||||||
|
|
||||||
|
; Extract a literal value from a parsed Tcl word (compound, braced, quoted).
|
||||||
|
; Returns nil if the word is not literal (e.g., contains $-substitution).
|
||||||
|
(define
|
||||||
|
tcl-oo-word-value
|
||||||
|
(fn
|
||||||
|
(word)
|
||||||
|
(let
|
||||||
|
((t (get word :type)))
|
||||||
|
(cond
|
||||||
|
((equal? t "braced") (get word :value))
|
||||||
|
((equal? t "quoted") (get word :value))
|
||||||
|
((equal? t "compound")
|
||||||
|
(let
|
||||||
|
((parts (get word :parts)))
|
||||||
|
(let
|
||||||
|
((all-text?
|
||||||
|
(reduce
|
||||||
|
(fn (a p) (and a (equal? (get p :type) "text")))
|
||||||
|
true
|
||||||
|
parts)))
|
||||||
|
(if
|
||||||
|
all-text?
|
||||||
|
(join "" (map (fn (p) (get p :value)) parts))
|
||||||
|
nil))))
|
||||||
|
(else (get word :value))))))
|
||||||
|
|
||||||
|
; Recursive scan over parsed Tcl commands building a class record.
|
||||||
|
; Top-level so the recursive call resolves correctly.
|
||||||
|
(define
|
||||||
|
tcl-oo-scan-class-body
|
||||||
|
(fn
|
||||||
|
(cmds rec)
|
||||||
|
(if
|
||||||
|
(= 0 (len cmds))
|
||||||
|
rec
|
||||||
|
(let
|
||||||
|
((cmd (first cmds)))
|
||||||
|
(let
|
||||||
|
((words (get cmd :words)))
|
||||||
|
(if
|
||||||
|
(= 0 (len words))
|
||||||
|
(tcl-oo-scan-class-body (rest cmds) rec)
|
||||||
|
(let
|
||||||
|
((kw (tcl-oo-word-value (first words))))
|
||||||
|
(cond
|
||||||
|
((equal? kw "superclass")
|
||||||
|
(tcl-oo-scan-class-body
|
||||||
|
(rest cmds)
|
||||||
|
(assoc rec :super (tcl-oo-word-value (nth words 1)))))
|
||||||
|
((equal? kw "constructor")
|
||||||
|
(tcl-oo-scan-class-body
|
||||||
|
(rest cmds)
|
||||||
|
(assoc rec :ctor {:args (tcl-oo-word-value (nth words 1)) :body (tcl-oo-word-value (nth words 2))})))
|
||||||
|
((equal? kw "destructor")
|
||||||
|
(tcl-oo-scan-class-body
|
||||||
|
(rest cmds)
|
||||||
|
(assoc rec :dtor {:body (tcl-oo-word-value (nth words 1))})))
|
||||||
|
((equal? kw "method")
|
||||||
|
(let
|
||||||
|
((mname (tcl-oo-word-value (nth words 1)))
|
||||||
|
(margs (tcl-oo-word-value (nth words 2)))
|
||||||
|
(mbody (tcl-oo-word-value (nth words 3))))
|
||||||
|
(tcl-oo-scan-class-body
|
||||||
|
(rest cmds)
|
||||||
|
(assoc
|
||||||
|
rec
|
||||||
|
:methods
|
||||||
|
(assoc (or (get rec :methods) {}) mname {:args margs :body mbody})))))
|
||||||
|
(else (tcl-oo-scan-class-body (rest cmds) rec))))))))))
|
||||||
|
|
||||||
|
; Parse class body — a Tcl script with commands `superclass NAME`,
|
||||||
|
; `constructor {args} {body}`, `destructor {body}`, `method NAME {args} {body}`.
|
||||||
|
; Returns a class record dict.
|
||||||
|
(define
|
||||||
|
tcl-oo-parse-class-body
|
||||||
|
(fn
|
||||||
|
(body)
|
||||||
|
(tcl-oo-scan-class-body
|
||||||
|
(tcl-tokenize body)
|
||||||
|
{:methods {} :ctor nil :dtor nil :super nil})))
|
||||||
|
|
||||||
|
; Find a method by walking class chain (this->super->...).
|
||||||
|
; Returns the method record {:args :body} or nil.
|
||||||
|
(define
|
||||||
|
tcl-oo-find-method
|
||||||
|
(fn
|
||||||
|
(interp class-name mname)
|
||||||
|
(let
|
||||||
|
((classes (or (get interp :classes) {})))
|
||||||
|
(let
|
||||||
|
((cls (get classes class-name)))
|
||||||
|
(if
|
||||||
|
(nil? cls)
|
||||||
|
nil
|
||||||
|
(let
|
||||||
|
((m (get (or (get cls :methods) {}) mname)))
|
||||||
|
(if
|
||||||
|
(not (nil? m))
|
||||||
|
m
|
||||||
|
(let
|
||||||
|
((super (get cls :super)))
|
||||||
|
(if
|
||||||
|
(nil? super)
|
||||||
|
nil
|
||||||
|
(tcl-oo-find-method interp super mname))))))))))
|
||||||
|
|
||||||
|
; Dispatch a method call on object. Sets up `self`, `my`, `class` in proc body.
|
||||||
|
(define
|
||||||
|
tcl-oo-call-method
|
||||||
|
(fn
|
||||||
|
(interp objname mname call-args)
|
||||||
|
(let
|
||||||
|
((objects (or (get interp :oo-objects) {})))
|
||||||
|
(let
|
||||||
|
((obj (get objects objname)))
|
||||||
|
(if
|
||||||
|
(nil? obj)
|
||||||
|
(error (str "oo: no such object: " objname))
|
||||||
|
(let
|
||||||
|
((cls-name (get obj :class)))
|
||||||
|
(let
|
||||||
|
((m (tcl-oo-find-method interp cls-name mname)))
|
||||||
|
(if
|
||||||
|
(nil? m)
|
||||||
|
(error (str "oo: object \"" objname "\" has no method \"" mname "\""))
|
||||||
|
; Wrap method as a proc-call; bind self, args
|
||||||
|
(let
|
||||||
|
((pdef {:args (get m :args) :body (get m :body)}))
|
||||||
|
(let
|
||||||
|
((interp-with-self (tcl-var-set interp "self" objname)))
|
||||||
|
(tcl-call-proc interp-with-self mname pdef call-args)))))))))))
|
||||||
|
|
||||||
|
; Dispatcher registered as the object's command: handles `obj method ?args ...?`
|
||||||
|
; Uses a closure-style approach by having the dispatcher take obj-name baked in.
|
||||||
|
(define
|
||||||
|
tcl-oo-make-obj-dispatcher
|
||||||
|
(fn
|
||||||
|
(objname)
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(if
|
||||||
|
(= 0 (len args))
|
||||||
|
(error (str "oo: " objname ": method name required"))
|
||||||
|
(tcl-oo-call-method interp objname (first args) (rest args))))))
|
||||||
|
|
||||||
|
; Class dispatcher — handles `ClsName new ?args ...?` and similar.
|
||||||
|
(define
|
||||||
|
tcl-oo-make-class-dispatcher
|
||||||
|
(fn
|
||||||
|
(cname)
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(if
|
||||||
|
(= 0 (len args))
|
||||||
|
(error (str "oo: class " cname ": subcommand required"))
|
||||||
|
(let
|
||||||
|
((sub (first args)) (rest-args (rest args)))
|
||||||
|
(cond
|
||||||
|
((equal? sub "new")
|
||||||
|
; Allocate object; call constructor if present
|
||||||
|
(let
|
||||||
|
((counter (or (get interp :oo-counter) 0)))
|
||||||
|
(let
|
||||||
|
((objname (str "::oo::object" counter)))
|
||||||
|
(let
|
||||||
|
((classes (or (get interp :classes) {})))
|
||||||
|
(let
|
||||||
|
((cls (get classes cname)))
|
||||||
|
(let
|
||||||
|
((interp1
|
||||||
|
(assoc
|
||||||
|
interp
|
||||||
|
:oo-counter
|
||||||
|
(+ counter 1)
|
||||||
|
:oo-objects
|
||||||
|
(assoc (or (get interp :oo-objects) {}) objname {:class cname :slots {}}))))
|
||||||
|
(let
|
||||||
|
((dispatcher (tcl-oo-make-obj-dispatcher objname)))
|
||||||
|
(let
|
||||||
|
((interp2 (tcl-register interp1 objname dispatcher)))
|
||||||
|
(let
|
||||||
|
((interp3
|
||||||
|
(if
|
||||||
|
(nil? (get cls :ctor))
|
||||||
|
interp2
|
||||||
|
(let
|
||||||
|
((ctor (get cls :ctor)))
|
||||||
|
(let
|
||||||
|
((interp-with-self (tcl-var-set interp2 "self" objname)))
|
||||||
|
(let
|
||||||
|
((cr (tcl-call-proc interp-with-self "constructor" ctor rest-args)))
|
||||||
|
(assoc cr :result objname)))))))
|
||||||
|
(assoc interp3 :result objname))))))))))
|
||||||
|
(else (error (str "oo: class " cname " unknown subcommand: " sub)))))))))
|
||||||
|
|
||||||
|
; oo::class create NAME body
|
||||||
|
; args = (create NAME body)
|
||||||
|
(define
|
||||||
|
tcl-cmd-oo-class
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(if
|
||||||
|
(< (len args) 2)
|
||||||
|
(error "oo::class: wrong # args")
|
||||||
|
(let
|
||||||
|
((sub (first args)))
|
||||||
|
(cond
|
||||||
|
((equal? sub "create")
|
||||||
|
(let
|
||||||
|
((cname (nth args 1))
|
||||||
|
(body (if (> (len args) 2) (nth args 2) "")))
|
||||||
|
(let
|
||||||
|
((rec (tcl-oo-parse-class-body body)))
|
||||||
|
(let
|
||||||
|
((classes (or (get interp :classes) {})))
|
||||||
|
(let
|
||||||
|
((with-class (assoc interp :classes (assoc classes cname rec))))
|
||||||
|
(let
|
||||||
|
((dispatcher (tcl-oo-make-class-dispatcher cname)))
|
||||||
|
(assoc
|
||||||
|
(tcl-register with-class cname dispatcher)
|
||||||
|
:result cname)))))))
|
||||||
|
(else (error (str "oo::class: unknown subcommand: " sub))))))))
|
||||||
|
|
||||||
|
; oo::object — placeholder; rarely used directly
|
||||||
|
(define
|
||||||
|
tcl-cmd-oo-object
|
||||||
|
(fn
|
||||||
|
(interp args)
|
||||||
|
(error "oo::object: not implemented as direct command")))
|
||||||
|
|
||||||
; ============================================================
|
; ============================================================
|
||||||
; Socket: TCP client and server (Phase 5c)
|
; Socket: TCP client and server (Phase 5c)
|
||||||
; ============================================================
|
; ============================================================
|
||||||
@@ -3783,6 +4496,16 @@
|
|||||||
((i (tcl-register i "linsert" tcl-cmd-linsert)))
|
((i (tcl-register i "linsert" tcl-cmd-linsert)))
|
||||||
(let
|
(let
|
||||||
((i (tcl-register i "concat" tcl-cmd-concat)))
|
((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
|
(let
|
||||||
((i (tcl-register i "split" tcl-cmd-split)))
|
((i (tcl-register i "split" tcl-cmd-split)))
|
||||||
(let
|
(let
|
||||||
@@ -3845,6 +4568,10 @@
|
|||||||
((i (tcl-register i "socket" tcl-cmd-socket)))
|
((i (tcl-register i "socket" tcl-cmd-socket)))
|
||||||
(let
|
(let
|
||||||
((i (tcl-register i "_sock-do-accept" tcl-cmd-_sock-do-accept)))
|
((i (tcl-register i "_sock-do-accept" tcl-cmd-_sock-do-accept)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "oo::class" tcl-cmd-oo-class)))
|
||||||
|
(let
|
||||||
|
((i (tcl-register i "oo::object" tcl-cmd-oo-object)))
|
||||||
(let
|
(let
|
||||||
((i (tcl-register i "file" tcl-cmd-file)))
|
((i (tcl-register i "file" tcl-cmd-file)))
|
||||||
(let
|
(let
|
||||||
@@ -3856,4 +4583,4 @@
|
|||||||
(tcl-register
|
(tcl-register
|
||||||
i
|
i
|
||||||
"array"
|
"array"
|
||||||
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||||
|
|||||||
@@ -57,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
|
|||||||
(eval "tcl-test-summary")
|
(eval "tcl-test-summary")
|
||||||
EPOCHS
|
EPOCHS
|
||||||
|
|
||||||
OUTPUT=$(timeout 2400 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||||
|
|
||||||
# Extract summary line from epoch 11 output
|
# Extract summary line from epoch 11 output
|
||||||
|
|||||||
@@ -415,6 +415,268 @@
|
|||||||
:result)
|
: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")
|
||||||
|
|
||||||
|
; 83-87. Phase 7a try/trap with varlist
|
||||||
|
(ok "try-trap-prefix-match"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"try {throw {ARITH DIVZERO} divide-by-zero} trap {ARITH} {res} {set caught $res}")
|
||||||
|
:result)
|
||||||
|
"divide-by-zero")
|
||||||
|
|
||||||
|
(ok "try-trap-full-pattern"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"try {throw {FOO BAR} bad} trap {FOO BAR} {res} {return matched-foo-bar}")
|
||||||
|
:result)
|
||||||
|
"matched-foo-bar")
|
||||||
|
|
||||||
|
(ok "try-on-error-opts"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"try {error oops} on error {res opts} {dict get $opts -code}")
|
||||||
|
:result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "try-trap-no-match-falls-through"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"set caught notrun\ncatch {try {throw {NOPE} bad} trap {OTHER} {r} {set caught matched}}\nset caught")
|
||||||
|
:result)
|
||||||
|
"notrun")
|
||||||
|
|
||||||
|
(ok "try-trap-then-on-error"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"try {error generic} trap {SPECIFIC} {r} {return trap-fired} on error {r} {return on-error-fired}")
|
||||||
|
:result)
|
||||||
|
"on-error-fired")
|
||||||
|
|
||||||
|
; 88-92. Phase 7b exec pipelines + redirection
|
||||||
|
(ok "exec-pipeline-tr"
|
||||||
|
(get (run "exec echo hello world | tr a-z A-Z") :result)
|
||||||
|
"HELLO WORLD")
|
||||||
|
|
||||||
|
(ok "exec-pipeline-wc"
|
||||||
|
(get (run "exec /bin/echo abc | wc -c") :result)
|
||||||
|
"4")
|
||||||
|
|
||||||
|
(ok "exec-redirect-stdout"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"set f /tmp/tcl-7b-out.txt\nexec echo hello > $f\nset r [exec cat $f]\nfile delete $f\nreturn $r")
|
||||||
|
:result)
|
||||||
|
"hello")
|
||||||
|
|
||||||
|
(ok "exec-redirect-stdin"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"set f /tmp/tcl-7b-in.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset r [exec cat < $f]\nfile delete $f\nreturn $r")
|
||||||
|
:result)
|
||||||
|
"hi")
|
||||||
|
|
||||||
|
(ok "exec-pipeline-three-stages"
|
||||||
|
(get (run "exec echo {alpha beta gamma} | tr { } \\n | wc -l") :result)
|
||||||
|
"3")
|
||||||
|
|
||||||
|
; 93-99. Phase 7c string command audit
|
||||||
|
(ok "string-equal"
|
||||||
|
(get (run "string equal hello hello") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "string-equal-nocase"
|
||||||
|
(get (run "string equal -nocase HELLO hello") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "string-totitle"
|
||||||
|
(get (run "string totitle hello") :result)
|
||||||
|
"Hello")
|
||||||
|
|
||||||
|
(ok "string-reverse"
|
||||||
|
(get (run "string reverse hello") :result)
|
||||||
|
"olleh")
|
||||||
|
|
||||||
|
(ok "string-replace"
|
||||||
|
(get (run "string replace hello 1 3 ZZZ") :result)
|
||||||
|
"hZZZo")
|
||||||
|
|
||||||
|
(ok "string-is-xdigit-yes"
|
||||||
|
(get (run "string is xdigit ff00aa") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "string-is-true-yes"
|
||||||
|
(get (run "string is true yes") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
; 100-105. Phase 7e regexp anchoring/boundary audit
|
||||||
|
(ok "regexp-anchor-start"
|
||||||
|
(get (run "regexp {^hello} hello-world") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "regexp-anchor-end"
|
||||||
|
(get (run "regexp {world$} hello-world") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "regexp-word-boundary"
|
||||||
|
(get (run "regexp {\\bword\\b} \"the word here\"") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "regexp-nocase"
|
||||||
|
(get (run "regexp -nocase {HELLO} hello") :result)
|
||||||
|
"1")
|
||||||
|
|
||||||
|
(ok "regexp-capture-var"
|
||||||
|
(get (run "regexp {[0-9]+} abc123def captured\nset captured") :result)
|
||||||
|
"123")
|
||||||
|
|
||||||
|
(ok "regsub-all"
|
||||||
|
(get (run "regsub -all {[0-9]+} a1b22c333 X") :result)
|
||||||
|
"aXbXcX")
|
||||||
|
|
||||||
|
; 106-110. Phase 7d TclOO basics
|
||||||
|
(ok "oo-class-method"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"oo::class create C {\nmethod get {} { return 42 }\n}\nset c [C new]\n$c get")
|
||||||
|
:result)
|
||||||
|
"42")
|
||||||
|
|
||||||
|
(ok "oo-constructor"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"oo::class create G {\nconstructor {n} { set ::gname $n }\nmethod hello {} { return [string cat \"hi \" $::gname] }\n}\nset g [G new World]\n$g hello")
|
||||||
|
:result)
|
||||||
|
"hi World")
|
||||||
|
|
||||||
|
(ok "oo-inheritance-overridden"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Dog {\nsuperclass Animal\nmethod sound {} { return woof }\n}\nset d [Dog new]\n$d sound")
|
||||||
|
:result)
|
||||||
|
"woof")
|
||||||
|
|
||||||
|
(ok "oo-inheritance-inherited"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"oo::class create Animal {\nmethod sound {} { return generic }\n}\noo::class create Cat {\nsuperclass Animal\n}\nset c [Cat new]\n$c sound")
|
||||||
|
:result)
|
||||||
|
"generic")
|
||||||
|
|
||||||
|
(ok "oo-multiple-instances"
|
||||||
|
(get
|
||||||
|
(run
|
||||||
|
"oo::class create N {\nconstructor {x} { set ::nval $x }\nmethod get {} { return $::nval }\n}\nset a [N new 1]\nset b [N new 99]\n$b get")
|
||||||
|
:result)
|
||||||
|
"99")
|
||||||
|
|
||||||
(dict
|
(dict
|
||||||
"passed"
|
"passed"
|
||||||
tcl-idiom-pass
|
tcl-idiom-pass
|
||||||
|
|||||||
@@ -167,7 +167,9 @@
|
|||||||
(begin
|
(begin
|
||||||
(when (= (cur) "}") (advance! 1))
|
(when (= (cur) "}") (advance! 1))
|
||||||
{:type "var" :name name}))))))
|
{:type "var" :name name}))))))
|
||||||
((tcl-ident-start? (cur))
|
((or
|
||||||
|
(tcl-ident-start? (cur))
|
||||||
|
(and (= (cur) ":") (= (char-at 1) ":")))
|
||||||
(let ((start pos))
|
(let ((start pos))
|
||||||
(begin
|
(begin
|
||||||
(scan-ns-name!)
|
(scan-ns-name!)
|
||||||
|
|||||||
Reference in New Issue
Block a user