From 35511db15baf63196e7a18013049b4be059c732c Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 16:29:28 +0000 Subject: [PATCH] tcl: array get/set/names/size/exists/unset commands (+8 tests, 337 total) Co-Authored-By: Claude Sonnet 4.6 --- lib/tcl/runtime.sx | 146 +++++++++++++++++++++++++++++++++++++++++- lib/tcl/tests/eval.sx | 48 ++++++++++++++ 2 files changed, 193 insertions(+), 1 deletion(-) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index f8965052..5fc413b2 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -2903,6 +2903,150 @@ (define tcl-cmd-tell (fn (interp args) (assoc interp :result "0"))) (define tcl-cmd-flush (fn (interp args) (assoc interp :result ""))) +(define + tcl-cmd-array + (fn + (interp args) + (if + (= 0 (len args)) + (error "array: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ((equal? sub "get") + (if (= 0 (len rest-args)) + (error "array get: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals)))) + (let + ((filtered + (if + (nil? pattern) + arr-keys + (filter + (fn (k) + (let ((kn (substring k pl (- (string-length k) 1)))) + (tcl-glob-match (split pattern "") (split kn "")))) + arr-keys)))) + (assoc interp :result + (join " " + (reduce + (fn (acc k) + (let ((kn (substring k pl (- (string-length k) 1)))) + (append acc (list kn) (list (get locals k))))) + (list) + filtered)))))))))) + ((equal? sub "set") + (if + (< (len rest-args) 2) + (error "array set: wrong # args") + (let + ((arr-name (first rest-args)) + (flat (tcl-list-split (nth rest-args 1)))) + (let + loop + ((pairs flat) (acc interp)) + (if + (< (len pairs) 2) + (assoc acc :result "") + (loop + (rest (rest pairs)) + (tcl-var-set acc + (str arr-name "(" (first pairs) ")") + (nth pairs 1)))))))) + ((equal? sub "names") + (if + (= 0 (len rest-args)) + (error "array names: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals)))) + (let + ((filtered + (if + (nil? pattern) + arr-keys + (filter + (fn (k) + (let ((kn (substring k pl (- (string-length k) 1)))) + (tcl-glob-match (split pattern "") (split kn "")))) + arr-keys)))) + (assoc interp :result + (join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered)))))))))) + ((equal? sub "size") + (if + (= 0 (len rest-args)) + (error "array size: wrong # args") + (let + ((prefix (str (first rest-args) "(")) + (locals (get (get interp :frame) :locals))) + (assoc interp :result + (str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals)))))))) + ((equal? sub "exists") + (if + (= 0 (len rest-args)) + (error "array exists: wrong # args") + (let + ((prefix (str (first rest-args) "(")) + (locals (get (get interp :frame) :locals))) + (assoc interp :result + (if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0"))))) + ((equal? sub "unset") + (if + (= 0 (len rest-args)) + (error "array unset: wrong # args") + (let + ((arr-name (first rest-args)) + (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil))) + (let + ((prefix (str arr-name "(")) + (locals (get (get interp :frame) :locals))) + (let + ((pl (string-length prefix))) + (let + ((to-delete + (filter + (fn (k) + (if + (tcl-starts-with? k prefix) + (if + (nil? pattern) + true + (let ((kn (substring k pl (- (string-length k) 1)))) + (tcl-glob-match (split pattern "") (split kn "")))) + false)) + (keys locals)))) + (let + ((new-locals + (reduce + (fn (acc k) + (if + (contains? to-delete k) + acc + (assoc acc k (get locals k)))) + {} + (keys locals)))) + (assoc interp + :frame (assoc (get interp :frame) :locals new-locals) + :result "")))))))) + (else (error (str "array: unknown subcommand \"" sub "\"")))))))) + + (define tcl-cmd-apply (fn @@ -3194,4 +3338,4 @@ ((i (tcl-register i "flush" tcl-cmd-flush))) (let ((i (tcl-register i "file" tcl-cmd-file))) (let ((i (tcl-register i "regexp" tcl-cmd-regexp))) - (let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (tcl-register i "apply" tcl-cmd-apply))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + (let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx index 5352646c..da980012 100644 --- a/lib/tcl/tests/eval.sx +++ b/lib/tcl/tests/eval.sx @@ -329,6 +329,54 @@ (run "proc with-temp-var {varname tempval body} {\n upvar 1 $varname v\n set saved $v\n set v $tempval\n uplevel 1 $body\n set v $saved\n}\nset x 100\nwith-temp-var x 999 {\n set captured $x\n}\nlist $x $captured") :result) "100 999") + (ok + "array-set-get" + (get + (run "array set a {x 1 y 2 z 3}; array get a x") + :result) + "x 1") + (ok + "array-names" + (get + (run "array set a {p 10 q 20}; lsort [array names a]") + :result) + "p q") + (ok + "array-size" + (get + (run "array set a {x 1 y 2 z 3}; array size a") + :result) + "3") + (ok + "array-exists-true" + (get + (run "array set a {x 1}; array exists a") + :result) + "1") + (ok + "array-exists-false" + (get + (run "array exists nosucharray") + :result) + "0") + (ok + "array-unset-key" + (get + (run "array set a {x 1 y 2 z 3}; array unset a y; lsort [array names a]") + :result) + "x z") + (ok + "array-scalar-access" + (get + (run "set a(foo) hello; set a(bar) world; set a(foo)") + :result) + "hello") + (ok + "array-get-all" + (get + (run "set a(k) v; set pairs [array get a]; llength $pairs") + :result) + "2") (dict "passed" tcl-eval-pass