diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index a4df8bf8..92795afe 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -1334,6 +1334,270 @@ (else (error (str "string: unknown subcommand: " sub)))))))) +; --- list command helpers --- + +; Quote a single list element: add braces if it contains a space or is empty +(define + tcl-list-quote-elem + (fn + (elem) + (if + (or (equal? elem "") (contains? (split elem "") " ")) + (str "{" elem "}") + elem))) + +; Build a Tcl list string from an SX list of string elements +(define + tcl-list-build + (fn (elems) (join " " (map tcl-list-quote-elem elems)))) + +; Resolve "end" index to numeric value given list length +(define + tcl-end-index + (fn + (s n) + (if (equal? s "end") (- n 1) (parse-int s)))) + +; Insertion sort for list commands (comparator: fn(a b) -> true if a before b) +(define + tcl-insert-sorted + (fn + (lst before? x) + (if + (= 0 (len lst)) + (list x) + (if + (before? x (first lst)) + (append (list x) lst) + (append (list (first lst)) (tcl-insert-sorted (rest lst) before? x)))))) + +(define + tcl-insertion-sort + (fn + (lst before?) + (reduce + (fn (sorted x) (tcl-insert-sorted sorted before? x)) + (list) + lst))) + +; --- list commands --- + +(define + tcl-cmd-list + (fn + (interp args) + (assoc interp :result (tcl-list-build args)))) + +(define + tcl-cmd-lindex + (fn + (interp args) + (let + ((elems (tcl-list-split (first args))) + (idx (tcl-end-index (nth args 1) (len (tcl-list-split (first args)))))) + (assoc + interp + :result + (if + (or (< idx 0) (>= idx (len elems))) + "" + (nth elems idx)))))) + +(define + tcl-cmd-lrange + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (fi (tcl-end-index (nth args 1) (len elems))) + (li (tcl-end-index (nth args 2) (len elems)))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li n) (- n 1) li))) + (assoc + interp + :result + (if + (> f l) + "" + (tcl-list-build (slice elems f (+ l 1)))))))))) + +(define + tcl-cmd-llength + (fn + (interp args) + (assoc interp :result (str (len (tcl-list-split (first args))))))) + +(define + tcl-cmd-lreverse + (fn + (interp args) + (assoc + interp + :result + (tcl-list-build (tcl-reverse-list (tcl-list-split (first args))))))) + +(define + tcl-cmd-lsearch + (fn + (interp args) + (let + ((exact? (and (> (len args) 2) (equal? (first args) "-exact"))) + (list-str (if (and (> (len args) 2) (equal? (first args) "-exact")) (nth args 1) (first args))) + (value (if (and (> (len args) 2) (equal? (first args) "-exact")) (nth args 2) (nth args 1)))) + (let + ((elems (tcl-list-split list-str))) + (define + find-idx + (fn + (lst i) + (if + (= 0 (len lst)) + "-1" + (if + (equal? (first lst) value) + (str i) + (find-idx (rest lst) (+ i 1)))))) + (assoc interp :result (find-idx elems 0)))))) + +(define + tcl-cmd-lsort + (fn + (interp args) + (define + parse-opts + (fn + (remaining) + (if + (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) + {:mode "ascii" :decreasing false :list-str (first remaining)} + (if + (equal? (first remaining) "-integer") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "integer")) + (if + (equal? (first remaining) "-real") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "real")) + (if + (equal? (first remaining) "-dictionary") + (let ((r (parse-opts (rest remaining)))) (assoc r :mode "dictionary")) + (if + (equal? (first remaining) "-decreasing") + (let ((r (parse-opts (rest remaining)))) (assoc r :decreasing true)) + {:mode "ascii" :decreasing false :list-str (first remaining)}))))))) + (let + ((opts (parse-opts args))) + (let + ((elems (tcl-list-split (get opts :list-str))) + (mode (get opts :mode)) + (decreasing? (get opts :decreasing))) + (let + ((before? + (if + (equal? mode "integer") + (fn (a b) (< (parse-int a) (parse-int b))) + (fn (a b) (< a b))))) + (let + ((sorted (tcl-insertion-sort elems before?))) + (assoc + interp + :result + (tcl-list-build + (if decreasing? (tcl-reverse-list sorted) sorted))))))))) + +(define + tcl-cmd-lreplace + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (fi (tcl-end-index (nth args 1) n)) + (li (tcl-end-index (nth args 2) n)) + (new-elems (slice args 3 (len args)))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li (- n 1)) (- n 1) li))) + (let + ((before (slice elems 0 f)) + (after (slice elems (+ l 1) n))) + (assoc + interp + :result + (tcl-list-build + (reduce + (fn (acc x) (append acc (list x))) + (reduce (fn (acc x) (append acc (list x))) before new-elems) + after))))))))) + +(define + tcl-cmd-linsert + (fn + (interp args) + (let + ((elems (tcl-list-split (first args)))) + (let + ((n (len elems)) + (raw-idx (nth args 1)) + (new-elems (slice args 2 (len args)))) + (let + ((idx + (if + (equal? raw-idx "end") + n + (let + ((i (parse-int raw-idx))) + (if (< i 0) 0 (if (> i n) n i)))))) + (let + ((before (slice elems 0 idx)) + (after (slice elems idx n))) + (assoc + interp + :result + (tcl-list-build + (reduce + (fn (acc x) (append acc (list x))) + (reduce (fn (acc x) (append acc (list x))) before new-elems) + after))))))))) + +(define + tcl-cmd-concat + (fn + (interp args) + (let + ((all-elems + (reduce + (fn (acc s) (append acc (tcl-list-split s))) + (list) + args))) + (assoc interp :result (tcl-list-build all-elems))))) + +(define + tcl-cmd-split + (fn + (interp args) + (let + ((s (first args)) + (sep (if (> (len args) 1) (nth args 1) " "))) + (let + ((parts + (if + (equal? sep " ") + (filter (fn (x) (not (equal? x ""))) (split s " ")) + (split s sep)))) + (assoc interp :result (tcl-list-build parts)))))) + +(define + tcl-cmd-join + (fn + (interp args) + (let + ((elems (tcl-list-split (first args))) + (sep (if (> (len args) 1) (nth args 1) " "))) + (assoc interp :result (join sep elems))))) + (define make-default-tcl-interp (fn @@ -1382,7 +1646,28 @@ ((i (tcl-register i "format" tcl-cmd-format))) (let ((i (tcl-register i "scan" tcl-cmd-scan))) - (tcl-register - i - "string" - tcl-cmd-string))))))))))))))))))))))))) + (let + ((i (tcl-register i "string" tcl-cmd-string))) + (let + ((i (tcl-register i "list" tcl-cmd-list))) + (let + ((i (tcl-register i "lindex" tcl-cmd-lindex))) + (let + ((i (tcl-register i "lrange" tcl-cmd-lrange))) + (let + ((i (tcl-register i "llength" tcl-cmd-llength))) + (let + ((i (tcl-register i "lreverse" tcl-cmd-lreverse))) + (let + ((i (tcl-register i "lsearch" tcl-cmd-lsearch))) + (let + ((i (tcl-register i "lsort" tcl-cmd-lsort))) + (let + ((i (tcl-register i "lreplace" tcl-cmd-lreplace))) + (let + ((i (tcl-register i "linsert" tcl-cmd-linsert))) + (let + ((i (tcl-register i "concat" tcl-cmd-concat))) + (let + ((i (tcl-register i "split" tcl-cmd-split))) + (tcl-register i "join" tcl-cmd-join))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx index 87512df6..f6648d56 100644 --- a/lib/tcl/tests/eval.sx +++ b/lib/tcl/tests/eval.sx @@ -234,6 +234,33 @@ (ok "str-is-alpha-no" (get (run "string is alpha hello1") :result) "0") (ok "str-is-boolean" (get (run "string is boolean true") :result) "1") (ok "str-cat" (get (run "string cat foo bar baz") :result) "foobarbaz") + ; --- list command tests --- + (ok "list-simple" (get (run "list a b c") :result) "a b c") + (ok "list-brace-elem" (get (run "list {a b} c") :result) "{a b} c") + (ok "list-empty" (get (run "list") :result) "") + (ok "lindex-1" (get (run "lindex {a b c} 1") :result) "b") + (ok "lindex-0" (get (run "lindex {a b c} 0") :result) "a") + (ok "lindex-oob" (get (run "lindex {a b c} 5") :result) "") + (ok "lrange" (get (run "lrange {a b c d} 1 2") :result) "b c") + (ok "lrange-full" (get (run "lrange {a b c} 0 end") :result) "a b c") + (ok "llength" (get (run "llength {a b c}") :result) "3") + (ok "llength-empty" (get (run "llength {}") :result) "0") + (ok "lreverse" (get (run "lreverse {1 2 3}") :result) "3 2 1") + (ok "lsearch-found" (get (run "lsearch {a b c} b") :result) "1") + (ok "lsearch-missing" (get (run "lsearch {a b c} z") :result) "-1") + (ok "lsearch-exact" (get (run "lsearch -exact {foo bar} foo") :result) "0") + (ok "lsort-asc" (get (run "lsort {banana apple cherry}") :result) "apple banana cherry") + (ok "lsort-int" (get (run "lsort -integer {10 2 30 5}") :result) "2 5 10 30") + (ok "lsort-dec" (get (run "lsort -decreasing {c a b}") :result) "c b a") + (ok "lreplace" (get (run "lreplace {a b c d} 1 2 X Y") :result) "a X Y d") + (ok "linsert" (get (run "linsert {a b c} 1 X Y") :result) "a X Y b c") + (ok "linsert-end" (get (run "linsert {a b} end Z") :result) "a b Z") + (ok "concat" (get (run "concat {a b} {c d}") :result) "a b c d") + (ok "split-sep" (get (run "split {a:b:c} :") :result) "a b c") + (ok "split-ws" (get (run "split {a b c}") :result) "a b c") + (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 "passed" tcl-eval-pass