tcl: string command — 16 subcommands + 29 tests (156 total)

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 <noreply@anthropic.com>

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

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