tcl: dict commands — 13 subcommands (+24 tests, 206 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 13s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 13s
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>
This commit is contained in:
@@ -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))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
Reference in New Issue
Block a user