From 9ed3e4faaf2d5e9e98787f241335325d27b564a7 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 6 May 2026 08:48:43 +0000 Subject: [PATCH] =?UTF-8?q?tcl:=20string=20command=20=E2=80=94=2016=20subc?= =?UTF-8?q?ommands=20+=2029=20tests=20(156=20total)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements tcl-cmd-string covering length, index, range, compare, match (glob * and ?), toupper, tolower, trim/trimleft/trimright, map, repeat, first, last, is (integer/double/alpha/alnum/digit/space/upper/lower/boolean), and cat. All 156 tcl tests pass (parse: 67, eval: 89). Co-Authored-By: Claude Sonnet 4.6 --- lib/tcl/runtime.sx | 441 +++++++++++++++++++++++++++++++++++++++++- lib/tcl/tests/eval.sx | 29 +++ 2 files changed, 466 insertions(+), 4 deletions(-) diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 1270fd8b..a4df8bf8 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -903,6 +903,437 @@ (define tcl-cmd-scan (fn (interp args) (assoc interp :result "0"))) +; --- string command helpers --- + +; glob match: pattern chars list, string chars list +(define + tcl-glob-match + (fn + (pat-chars str-chars) + (cond + ; both exhausted → success + ((and (= 0 (len pat-chars)) (= 0 (len str-chars))) true) + ; pattern exhausted but string remains → fail + ((= 0 (len pat-chars)) false) + ; leading * in pattern + ((equal? (first pat-chars) "*") + (let + ((rest-pat (rest pat-chars))) + ; * can match zero chars (skip *) or consume one str char and retry + (if + (tcl-glob-match rest-pat str-chars) + true + (if + (= 0 (len str-chars)) + false + (tcl-glob-match pat-chars (rest str-chars)))))) + ; string exhausted but pattern non-empty (and not *) → fail + ((= 0 (len str-chars)) false) + ; ? matches any single char + ((equal? (first pat-chars) "?") + (tcl-glob-match (rest pat-chars) (rest str-chars))) + ; literal match + ((equal? (first pat-chars) (first str-chars)) + (tcl-glob-match (rest pat-chars) (rest str-chars))) + ; literal mismatch + (else false)))) + +; toupper/tolower via char tables +(define + tcl-upcase-char + (fn + (c) + (cond + ((equal? c "a") "A") ((equal? c "b") "B") ((equal? c "c") "C") + ((equal? c "d") "D") ((equal? c "e") "E") ((equal? c "f") "F") + ((equal? c "g") "G") ((equal? c "h") "H") ((equal? c "i") "I") + ((equal? c "j") "J") ((equal? c "k") "K") ((equal? c "l") "L") + ((equal? c "m") "M") ((equal? c "n") "N") ((equal? c "o") "O") + ((equal? c "p") "P") ((equal? c "q") "Q") ((equal? c "r") "R") + ((equal? c "s") "S") ((equal? c "t") "T") ((equal? c "u") "U") + ((equal? c "v") "V") ((equal? c "w") "W") ((equal? c "x") "X") + ((equal? c "y") "Y") ((equal? c "z") "Z") + (else c)))) + +(define + tcl-downcase-char + (fn + (c) + (cond + ((equal? c "A") "a") ((equal? c "B") "b") ((equal? c "C") "c") + ((equal? c "D") "d") ((equal? c "E") "e") ((equal? c "F") "f") + ((equal? c "G") "g") ((equal? c "H") "h") ((equal? c "I") "i") + ((equal? c "J") "j") ((equal? c "K") "k") ((equal? c "L") "l") + ((equal? c "M") "m") ((equal? c "N") "n") ((equal? c "O") "o") + ((equal? c "P") "p") ((equal? c "Q") "q") ((equal? c "R") "r") + ((equal? c "S") "s") ((equal? c "T") "t") ((equal? c "U") "u") + ((equal? c "V") "v") ((equal? c "W") "w") ((equal? c "X") "x") + ((equal? c "Y") "y") ((equal? c "Z") "z") + (else c)))) + +; strip chars from left +(define + tcl-trim-left-chars + (fn + (chars strip-set) + (if + (or (= 0 (len chars)) (not (contains? strip-set (first chars)))) + chars + (tcl-trim-left-chars (rest chars) strip-set)))) + +; strip chars from right (reverse, trim left, reverse) +(define + tcl-reverse-list + (fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst))) + +(define + tcl-trim-right-chars + (fn + (chars strip-set) + (tcl-reverse-list (tcl-trim-left-chars (tcl-reverse-list chars) strip-set)))) + +; default whitespace set +(define + tcl-ws-set + (list " " "\t" "\n" "\r")) + +; string map: apply flat list of pairs old→new to string +(define + tcl-string-map-apply + (fn + (s pairs) + (if + (< (len pairs) 2) + s + (let + ((old (first pairs)) (new-s (nth pairs 1)) (rest-pairs (rest (rest pairs)))) + (let + ((old-chars (split old "")) + (old-len (string-length old))) + (let + ((go + (fn + (i acc) + (if + (>= i (string-length s)) + acc + (let + ((chunk (if (> (+ i old-len) (string-length s)) "" (substring s i (+ i old-len))))) + (if + (equal? chunk old) + (go (+ i old-len) (str acc new-s)) + (go (+ i 1) (str acc (substring s i (+ i 1)))))))))) + (tcl-string-map-apply (go 0 "") rest-pairs))))))) + +; string first: index of needle in haystack starting at start +(define + tcl-string-first + (fn + (needle haystack start) + (let + ((nl (string-length needle)) (hl (string-length haystack))) + (if + (= nl 0) + (str start) + (let + ((go + (fn + (i) + (if + (> (+ i nl) hl) + "-1" + (if + (equal? (substring haystack i (+ i nl)) needle) + (str i) + (go (+ i 1))))))) + (go start)))))) + +; string last: last index of needle in haystack up to end +(define + tcl-string-last + (fn + (needle haystack end-idx) + (let + ((nl (string-length needle)) (hl (string-length haystack))) + (let + ((bound (if (< end-idx 0) (- hl 1) (if (>= end-idx hl) (- hl 1) end-idx)))) + (if + (= nl 0) + (str bound) + (let + ((go + (fn + (i) + (if + (< i 0) + "-1" + (if + (and + (<= (+ i nl) hl) + (equal? (substring haystack i (+ i nl)) needle)) + (str i) + (go (- i 1))))))) + (go (- (+ bound 1) nl)))))))) + +; string is: check string class +(define + tcl-string-is + (fn + (class s) + (let + ((chars (split s "")) + (n (string-length s))) + (cond + ((equal? class "integer") + (if + (= n 0) + "0" + (let + ((start (if (or (equal? (first chars) "-") (equal? (first chars) "+")) 1 0))) + (if + (= start n) + "0" + (if + (reduce + (fn (ok c) (and ok (tcl-expr-digit? c))) + true + (slice chars start n)) + "1" + "0"))))) + ((equal? class "double") + (if + (= n 0) + "0" + (if + (reduce + (fn (ok c) (and ok (or (tcl-expr-digit? c) (equal? c ".") (equal? c "-") (equal? c "+") (equal? c "e") (equal? c "E")))) + true + chars) + "1" + "0"))) + ((equal? class "alpha") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (tcl-expr-alpha? c))) true chars) + "1" + "0"))) + ((equal? class "alnum") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (or (tcl-expr-alpha? c) (tcl-expr-digit? c)))) true chars) + "1" + "0"))) + ((equal? class "digit") + (if + (= n 0) + "0" + (if + (reduce (fn (ok c) (and ok (tcl-expr-digit? c))) true chars) + "1" + "0"))) + ((equal? class "space") + (if + (= n 0) + "1" + (if + (reduce (fn (ok c) (and ok (tcl-expr-ws? c))) true chars) + "1" + "0"))) + ((equal? class "upper") + (if + (= n 0) + "0" + (if + (reduce + (fn + (ok c) + (and + ok + (contains? + (list "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" + "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z") + c))) + true + chars) + "1" + "0"))) + ((equal? class "lower") + (if + (= n 0) + "0" + (if + (reduce + (fn + (ok c) + (and + ok + (contains? + (list "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" + "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z") + c))) + true + chars) + "1" + "0"))) + ((equal? class "boolean") + (if + (or (equal? s "0") (equal? s "1") + (equal? s "true") (equal? s "false") + (equal? s "yes") (equal? s "no") + (equal? s "on") (equal? s "off")) + "1" + "0")) + (else "0"))))) + +(define + tcl-cmd-string + (fn + (interp args) + (if + (= 0 (len args)) + (error "string: wrong # args") + (let + ((sub (first args)) (rest-args (rest args))) + (cond + ; string length s + ((equal? sub "length") + (assoc interp :result (str (string-length (first rest-args))))) + ; string index s i + ((equal? sub "index") + (let + ((s (first rest-args)) (idx (parse-int (nth rest-args 1)))) + (let + ((n (string-length s))) + (if + (or (< idx 0) (>= idx n)) + (assoc interp :result "") + (assoc interp :result (substring s idx (+ idx 1))))))) + ; string range s first last + ((equal? sub "range") + (let + ((s (first rest-args)) + (fi (parse-int (nth rest-args 1))) + (li (parse-int (nth rest-args 2)))) + (let + ((n (string-length s))) + (let + ((f (if (< fi 0) 0 fi)) + (l (if (>= li n) (- n 1) li))) + (if + (> f l) + (assoc interp :result "") + (assoc interp :result (substring s f (+ l 1)))))))) + ; string compare s1 s2 + ((equal? sub "compare") + (let + ((s1 (first rest-args)) (s2 (nth rest-args 1))) + (assoc + interp + :result + (cond + ((equal? s1 s2) "0") + ((< s1 s2) "-1") + (else "1"))))) + ; string match pattern s + ((equal? sub "match") + (let + ((pat (first rest-args)) (s (nth rest-args 1))) + (assoc + interp + :result + (if (tcl-glob-match (split pat "") (split s "")) "1" "0")))) + ; string toupper s + ((equal? sub "toupper") + (let + ((s (first rest-args))) + (assoc + interp + :result + (join "" (map tcl-upcase-char (split s "")))))) + ; string tolower s + ((equal? sub "tolower") + (let + ((s (first rest-args))) + (assoc + interp + :result + (join "" (map tcl-downcase-char (split s "")))))) + ; string trim s ?chars? + ((equal? sub "trim") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (let + ((chars (split s ""))) + (assoc + interp + :result + (join "" (tcl-trim-right-chars (tcl-trim-left-chars chars strip-set) strip-set)))))) + ; string trimleft s ?chars? + ((equal? sub "trimleft") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (assoc + interp + :result + (join "" (tcl-trim-left-chars (split s "") strip-set))))) + ; string trimright s ?chars? + ((equal? sub "trimright") + (let + ((s (first rest-args)) + (strip-set (if (> (len rest-args) 1) (split (nth rest-args 1) "") tcl-ws-set))) + (assoc + interp + :result + (join "" (tcl-trim-right-chars (split s "") strip-set))))) + ; string map mapping s + ((equal? sub "map") + (let + ((mapping (first rest-args)) (s (nth rest-args 1))) + (assoc + interp + :result + (tcl-string-map-apply s (tcl-list-split mapping))))) + ; string repeat s n + ((equal? sub "repeat") + (let + ((s (first rest-args)) (n (parse-int (nth rest-args 1)))) + (assoc + interp + :result + (let + ((go (fn (i acc) (if (>= i n) acc (go (+ i 1) (str acc s)))))) + (go 0 ""))))) + ; string first needle haystack ?start? + ((equal? sub "first") + (let + ((needle (first rest-args)) + (haystack (nth rest-args 1)) + (start (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 0))) + (assoc interp :result (tcl-string-first needle haystack start)))) + ; string last needle haystack ?end? + ((equal? sub "last") + (let + ((needle (first rest-args)) + (haystack (nth rest-args 1)) + (end-idx (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) -1))) + (assoc interp :result (tcl-string-last needle haystack end-idx)))) + ; string is class s + ((equal? sub "is") + (let + ((class (first rest-args)) (s (nth rest-args 1))) + (assoc interp :result (tcl-string-is class s)))) + ; string cat ?args...? + ((equal? sub "cat") + (assoc interp :result (join "" rest-args))) + (else (error (str "string: unknown subcommand: " sub)))))))) + + (define make-default-tcl-interp (fn @@ -949,7 +1380,9 @@ ((i (tcl-register i "subst" tcl-cmd-subst))) (let ((i (tcl-register i "format" tcl-cmd-format))) - (tcl-register - i - "scan" - tcl-cmd-scan)))))))))))))))))))))))) + (let + ((i (tcl-register i "scan" tcl-cmd-scan))) + (tcl-register + i + "string" + tcl-cmd-string))))))))))))))))))))))))) diff --git a/lib/tcl/tests/eval.sx b/lib/tcl/tests/eval.sx index e3b71045..87512df6 100644 --- a/lib/tcl/tests/eval.sx +++ b/lib/tcl/tests/eval.sx @@ -205,6 +205,35 @@ "set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}") "r") "mid") + (ok "str-length" (get (run "string length hello") :result) "5") + (ok "str-length-empty" (get (run "string length {}") :result) "0") + (ok "str-index" (get (run "string index hello 1") :result) "e") + (ok "str-index-oob" (get (run "string index hello 99") :result) "") + (ok "str-range" (get (run "string range hello 1 3") :result) "ell") + (ok "str-range-clamp" (get (run "string range hello 3 99") :result) "lo") + (ok "str-compare-eq" (get (run "string compare abc abc") :result) "0") + (ok "str-compare-lt" (get (run "string compare abc abd") :result) "-1") + (ok "str-compare-gt" (get (run "string compare b a") :result) "1") + (ok "str-match-star" (get (run "string match h*o hello") :result) "1") + (ok "str-match-q" (get (run "string match h?llo hello") :result) "1") + (ok "str-match-no" (get (run "string match h*x hello") :result) "0") + (ok "str-toupper" (get (run "string toupper hello") :result) "HELLO") + (ok "str-tolower" (get (run "string tolower WORLD") :result) "world") + (ok "str-trim" (get (run "string trim { hi }") :result) "hi") + (ok "str-trimleft" (get (run "string trimleft { hi }") :result) "hi ") + (ok "str-trimright" (get (run "string trimright { hi }") :result) " hi") + (ok "str-trim-chars" (get (run "string trim {xxhelloxx} x") :result) "hello") + (ok "str-map" (get (run "string map {a X b Y} {abc}") :result) "XYc") + (ok "str-repeat" (get (run "string repeat ab 3") :result) "ababab") + (ok "str-first" (get (run "string first ll hello") :result) "2") + (ok "str-first-miss" (get (run "string first z hello") :result) "-1") + (ok "str-last" (get (run "string last l hello") :result) "3") + (ok "str-is-int" (get (run "string is integer 42") :result) "1") + (ok "str-is-not-int" (get (run "string is integer foo") :result) "0") + (ok "str-is-alpha" (get (run "string is alpha hello") :result) "1") + (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") (dict "passed" tcl-eval-pass