tcl: dict commands — 13 subcommands (+24 tests, 206 total)

Implements tcl-cmd-dict with create/get/set/unset/exists/keys/values/
size/for/update/merge/incr/append subcommands, plus helpers
tcl-dict-to-pairs, tcl-dict-from-pairs, tcl-dict-get, tcl-dict-set-pair,
tcl-dict-unset-key. Registers "dict" in make-default-tcl-interp.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/tcl/runtime.sx

@@ -1598,6 +1598,283 @@
         (sep (if (> (len args) 1) (nth args 1) " ")))
       (assoc interp :result (join sep elems)))))
 
+; --- dict command helpers ---
+
+; Parse flat dict string into SX list of [key val] pairs
+(define
+  tcl-dict-to-pairs
+  (fn
+    (dict-str)
+    (let
+      ((flat (tcl-list-split dict-str)))
+      (let
+        ((go
+          (fn
+            (lst acc)
+            (if
+              (= 0 (len lst))
+              acc
+              (if
+                (= 1 (len lst))
+                (error "dict: malformed dict (odd number of elements)")
+                (go (rest (rest lst)) (append acc (list (list (first lst) (nth lst 1))))))))))
+        (go flat (list))))))
+
+; Build flat dict string from SX list of [key val] pairs
+(define
+  tcl-dict-from-pairs
+  (fn
+    (pairs)
+    (tcl-list-build
+      (reduce
+        (fn (acc pair) (append (append acc (list (first pair))) (list (nth pair 1))))
+        (list)
+        pairs))))
+
+; Get value for key from flat dict string; returns nil if missing
+(define
+  tcl-dict-get
+  (fn
+    (dict-str key)
+    (let
+      ((flat (tcl-list-split dict-str)))
+      (let
+        ((go
+          (fn
+            (lst)
+            (if
+              (< (len lst) 2)
+              nil
+              (if
+                (equal? (first lst) key)
+                (nth lst 1)
+                (go (rest (rest lst))))))))
+        (go flat)))))
+
+; Set key=val in flat dict string; returns new flat dict string
+(define
+  tcl-dict-set-pair
+  (fn
+    (dict-str key val)
+    (let
+      ((pairs (tcl-dict-to-pairs dict-str)))
+      (let
+        ((found? (reduce (fn (acc pair) (or acc (equal? (first pair) key))) false pairs)))
+        (if
+          found?
+          (tcl-dict-from-pairs (map (fn (pair) (if (equal? (first pair) key) (list key val) pair)) pairs))
+          (tcl-dict-from-pairs (append pairs (list (list key val)))))))))
+
+; Remove key from flat dict string; returns new flat dict string
+(define
+  tcl-dict-unset-key
+  (fn
+    (dict-str key)
+    (tcl-dict-from-pairs
+      (filter (fn (pair) (not (equal? (first pair) key))) (tcl-dict-to-pairs dict-str)))))
+
+; --- dict command ---
+
+(define
+  tcl-cmd-dict
+  (fn
+    (interp args)
+    (if
+      (= 0 (len args))
+      (error "dict: wrong # args")
+      (let
+        ((sub (first args)) (rest-args (rest args)))
+        (cond
+          ; dict create ?key val …?
+          ((equal? sub "create")
+            (if
+              (= 1 (mod (len rest-args) 2))
+              (error "dict create: wrong # args (must be even)")
+              (assoc interp :result (tcl-list-build rest-args))))
+          ; dict get dict key
+          ((equal? sub "get")
+            (let
+              ((dict-str (first rest-args)) (key (nth rest-args 1)))
+              (let
+                ((val (tcl-dict-get dict-str key)))
+                (if
+                  (nil? val)
+                  (error (str "dict get: key \"" key "\" not known in dictionary"))
+                  (assoc interp :result val)))))
+          ; dict set varname key val
+          ((equal? sub "set")
+            (let
+              ((varname (first rest-args))
+                (key (nth rest-args 1))
+                (val (nth rest-args 2)))
+              (let
+                ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
+                (let
+                  ((new-dict (tcl-dict-set-pair cur key val)))
+                  (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))
+          ; dict unset varname key
+          ((equal? sub "unset")
+            (let
+              ((varname (first rest-args)) (key (nth rest-args 1)))
+              (let
+                ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
+                (let
+                  ((new-dict (tcl-dict-unset-key cur key)))
+                  (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))
+          ; dict exists dict key
+          ((equal? sub "exists")
+            (let
+              ((dict-str (first rest-args)) (key (nth rest-args 1)))
+              (assoc interp :result (if (nil? (tcl-dict-get dict-str key)) "0" "1"))))
+          ; dict keys dict ?pattern?
+          ((equal? sub "keys")
+            (let
+              ((dict-str (first rest-args))
+                (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
+              (let
+                ((all-keys (map first (tcl-dict-to-pairs dict-str))))
+                (let
+                  ((filtered
+                    (if
+                      (nil? pattern)
+                      all-keys
+                      (filter (fn (k) (tcl-glob-match (split pattern "") (split k ""))) all-keys))))
+                  (assoc interp :result (tcl-list-build filtered))))))
+          ; dict values dict
+          ((equal? sub "values")
+            (let
+              ((dict-str (first rest-args)))
+              (assoc interp :result (tcl-list-build (map (fn (pair) (nth pair 1)) (tcl-dict-to-pairs dict-str))))))
+          ; dict size dict
+          ((equal? sub "size")
+            (let
+              ((dict-str (first rest-args)))
+              (assoc interp :result (str (len (tcl-dict-to-pairs dict-str))))))
+          ; dict for {kvar vvar} dict body
+          ((equal? sub "for")
+            (let
+              ((var-pair-str (first rest-args))
+                (dict-str (nth rest-args 1))
+                (body (nth rest-args 2)))
+              (let
+                ((var-list (tcl-list-split var-pair-str)))
+                (let
+                  ((kvar (first var-list)) (vvar (nth var-list 1)))
+                  (let
+                    ((pairs (tcl-dict-to-pairs dict-str)))
+                    (define
+                      dict-for-loop
+                      (fn
+                        (cur-interp ps)
+                        (if
+                          (= 0 (len ps))
+                          cur-interp
+                          (let
+                            ((pair (first ps)))
+                            (let
+                              ((bound (tcl-var-set (tcl-var-set cur-interp kvar (first pair)) vvar (nth pair 1))))
+                              (let
+                                ((body-result (tcl-eval-string bound body)))
+                                (let
+                                  ((code (get body-result :code)))
+                                  (cond
+                                    ((= code 3) (assoc body-result :code 0))
+                                    ((= code 2) body-result)
+                                    ((= code 1) body-result)
+                                    (else (dict-for-loop (assoc body-result :code 0) (rest ps)))))))))))
+                    (dict-for-loop interp pairs))))))
+          ; dict update varname key var … body
+          ((equal? sub "update")
+            (let
+              ((varname (first rest-args)))
+              (let
+                ((n (len rest-args)))
+                (let
+                  ((body (nth rest-args (- n 1)))
+                    (kv-args (slice rest-args 1 (- n 1))))
+                  (let
+                    ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
+                    (let
+                      ((bound-interp
+                        (let
+                          ((bind-pairs
+                            (fn
+                              (i-interp remaining)
+                              (if
+                                (< (len remaining) 2)
+                                i-interp
+                                (let
+                                  ((k (first remaining)) (var (nth remaining 1)))
+                                  (let
+                                    ((val (tcl-dict-get cur k)))
+                                    (bind-pairs
+                                      (tcl-var-set i-interp var (if (nil? val) "" val))
+                                      (rest (rest remaining)))))))))
+                          (bind-pairs interp kv-args))))
+                      (let
+                        ((body-result (tcl-eval-string bound-interp body)))
+                        (let
+                          ((write-back
+                            (fn
+                              (i-interp remaining new-dict)
+                              (if
+                                (< (len remaining) 2)
+                                (assoc (tcl-var-set i-interp varname new-dict) :result new-dict)
+                                (let
+                                  ((k (first remaining)) (var (nth remaining 1)))
+                                  (let
+                                    ((new-val (frame-lookup (get body-result :frame) var)))
+                                    (write-back
+                                      i-interp
+                                      (rest (rest remaining))
+                                      (if (nil? new-val) (tcl-dict-unset-key new-dict k) (tcl-dict-set-pair new-dict k new-val)))))))))
+                          (write-back body-result kv-args cur)))))))))
+          ; dict merge ?dict…?
+          ((equal? sub "merge")
+            (let
+              ((merged
+                (reduce
+                  (fn
+                    (acc dict-str)
+                    (reduce
+                      (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1)))
+                      acc
+                      (tcl-dict-to-pairs dict-str)))
+                  ""
+                  rest-args)))
+              (assoc interp :result merged)))
+          ; dict incr varname key ?increment?
+          ((equal? sub "incr")
+            (let
+              ((varname (first rest-args))
+                (key (nth rest-args 1))
+                (delta (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 1)))
+              (let
+                ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
+                (let
+                  ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "0" v))))
+                  (let
+                    ((new-val (str (+ (parse-int old-val) delta))))
+                    (let
+                      ((new-dict (tcl-dict-set-pair cur key new-val)))
+                      (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))))
+          ; dict append varname key ?string…?
+          ((equal? sub "append")
+            (let
+              ((varname (first rest-args))
+                (key (nth rest-args 1))
+                (suffix (join "" (slice rest-args 2 (len rest-args)))))
+              (let
+                ((cur (let ((v (frame-lookup (get interp :frame) varname))) (if (nil? v) "" v))))
+                (let
+                  ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v))))
+                  (let
+                    ((new-val (str old-val suffix)))
+                    (let
+                      ((new-dict (tcl-dict-set-pair cur key new-val)))
+                      (assoc (tcl-var-set interp varname new-dict) :result new-dict)))))))
+          (else (error (str "dict: unknown subcommand \"" sub "\""))))))))
+
 (define
   make-default-tcl-interp
   (fn
@@ -1670,4 +1947,6 @@
                                                                       ((i (tcl-register i "concat" tcl-cmd-concat)))
                                                                       (let
                                                                         ((i (tcl-register i "split" tcl-cmd-split)))
-                                                                        (tcl-register i "join" tcl-cmd-join)))))))))))))))))))))))))))))))))))))
+                                                                        (let
+                                                                          ((i (tcl-register i "join" tcl-cmd-join)))
+                                                                          (tcl-register i "dict" tcl-cmd-dict))))))))))))))))))))))))))))))))))))))

lib/tcl/tests/eval.sx

@@ -261,6 +261,31 @@
     (ok "join-sep" (get (run "join {a b c} -") :result) "a-b-c")
     (ok "join-default" (get (run "join {a b c}") :result) "a b c")
     (ok "list-var" (get (run "set L {x y z}\nllength $L") :result) "3")
+    ; --- dict command tests ---
+    (ok "dict-create" (get (run "dict create a 1 b 2") :result) "a 1 b 2")
+    (ok "dict-create-empty" (get (run "dict create") :result) "")
+    (ok "dict-get" (get (run "dict get {a 1 b 2} a") :result) "1")
+    (ok "dict-get-b" (get (run "dict get {a 1 b 2} b") :result) "2")
+    (ok "dict-exists-yes" (get (run "dict exists {a 1 b 2} a") :result) "1")
+    (ok "dict-exists-no" (get (run "dict exists {a 1 b 2} z") :result) "0")
+    (ok "dict-set-new" (get (run "set d {}\ndict set d x 42") :result) "x 42")
+    (ok "dict-set-update" (get (run "set d {a 1 b 2}\ndict set d a 99") :result) "a 99 b 2")
+    (ok "dict-set-stored" (tcl-var-get (run "set d {a 1}\ndict set d b 2") "d") "a 1 b 2")
+    (ok "dict-unset" (get (run "set d {a 1 b 2}\ndict unset d a") :result) "b 2")
+    (ok "dict-unset-stored" (tcl-var-get (run "set d {a 1 b 2}\ndict unset d a") "d") "b 2")
+    (ok "dict-keys" (get (run "dict keys {a 1 b 2}") :result) "a b")
+    (ok "dict-keys-pattern" (get (run "dict keys {abc 1 abd 2 xyz 3} ab*") :result) "abc abd")
+    (ok "dict-values" (get (run "dict values {a 1 b 2}") :result) "1 2")
+    (ok "dict-size" (get (run "dict size {a 1 b 2 c 3}") :result) "3")
+    (ok "dict-size-empty" (get (run "dict size {}") :result) "0")
+    (ok "dict-for" (tcl-var-get (run "set acc {}\ndict for {k v} {a 1 b 2} {append acc $k$v}") "acc") "a1b2")
+    (ok "dict-merge-disjoint" (get (run "dict merge {a 1} {b 2}") :result) "a 1 b 2")
+    (ok "dict-merge-overlap" (get (run "dict merge {a 1 b 2} {b 99}") :result) "a 1 b 99")
+    (ok "dict-incr-existing" (get (run "set d {x 5}\ndict incr d x") :result) "x 6")
+    (ok "dict-incr-delta" (get (run "set d {x 5}\ndict incr d x 3") :result) "x 8")
+    (ok "dict-incr-missing" (get (run "set d {}\ndict incr d n") :result) "n 1")
+    (ok "dict-append" (get (run "set d {x hello}\ndict append d x _hi") :result) "x hello_hi")
+    (ok "dict-append-new" (get (run "set d {}\ndict append d k val") :result) "k val")
     (dict
       "passed"
       tcl-eval-pass