tcl: string command — 16 subcommands + 29 tests (156 total)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
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>
This commit is contained in:
@@ -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)))))))))))))))))))))))))
|
||||
|
||||
Reference in New Issue
Block a user