coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tcl: array get/set/names/size/exists/unset commands (+8 tests, 337 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Details

Browse Source 
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-06 16:29:28 +00:00
parent 40ce4df6b1
commit 35511db15b
2 changed files with 193 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

146
lib/tcl/runtime.sx
View File

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

48
lib/tcl/tests/eval.sx
View File

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