coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tcl: regexp + regsub commands wrapping SX regex primitives
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
Details

Browse Source 
regexp: -nocase/-all/-inline flags, optional matchVar + subgroup var args.
regsub: -all/-nocase flags, optional varName (stores result + returns count)
or inline use (returns result string). Both wrap make-regexp/regexp-match/
regexp-match-all/regexp-replace/regexp-replace-all. 329/329 tests green.
This commit is contained in:
giles
2026-05-06 15:31:36 +00:00
parent 21e8e51174
commit 0cc36450c4
1 changed files with 81 additions and 4 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
lib/tcl/runtime.sx
View File

@@ -2903,6 +2903,84 @@
(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))
(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
(define
tcl-cmd-regexp
(fn
(interp args)
(define parse-flags
(fn (as nocase? all? inline?)
(if (= 0 (len as))
{:nocase nocase? :all all? :inline inline? :rest as}
(cond
((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
((equal? (first as) "-all") (parse-flags (rest as) nocase? true inline?))
((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
(else {:nocase nocase? :all all? :inline inline? :rest as})))))
(let ((pf (parse-flags args false false false)))
(let ((nocase (get pf :nocase))
(all-mode (get pf :all))
(inline-mode (get pf :inline))
(ra (get pf :rest)))
(if (< (len ra) 2)
(error "regexp: wrong # args")
(let ((pattern (first ra))
(str-val (nth ra 1))
(var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
(let ((re (make-regexp pattern (if nocase "i" ""))))
(if all-mode
(assoc interp :result (str (len (regexp-match-all re str-val))))
(if inline-mode
(assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
(let ((m (regexp-match re str-val)))
(if (nil? m)
(assoc interp :result "0")
(let ((interp2
(if (> (len var-args) 0)
(tcl-var-set interp (first var-args) (get m :match))
interp)))
(let ((interp3
(let loop ((vi 1) (gs (get m :groups)) (acc interp2))
(if (or (= 0 (len gs)) (>= vi (len var-args))) acc
(loop (+ vi 1) (rest gs)
(tcl-var-set acc (nth var-args vi) (first gs)))))))
(assoc interp3 :result "1"))))))))))))))
(define
tcl-cmd-regsub
(fn
(interp args)
(define parse-flags
(fn (as all? nocase?)
(if (= 0 (len as))
{:all all? :nocase nocase? :rest as}
(cond
((equal? (first as) "-all") (parse-flags (rest as) true nocase?))
((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
(else {:all all? :nocase nocase? :rest as})))))
(let ((pf (parse-flags args false false)))
(let ((all-mode (get pf :all))
(nocase (get pf :nocase))
(ra (get pf :rest)))
(if (< (len ra) 3)
(error "regsub: wrong # args")
(let ((pattern (first ra))
(str-val (nth ra 1))
(replacement (nth ra 2))
(var-name (if (> (len ra) 3) (nth ra 3) nil)))
(let ((re (make-regexp pattern (if nocase "i" ""))))
(let ((result
(if all-mode
(regexp-replace-all re str-val replacement)
(regexp-replace re str-val replacement))))
(if (nil? var-name)
(assoc interp :result result)
(let ((count
(if all-mode
(len (regexp-match-all re str-val))
(if (nil? (regexp-match re str-val)) 0 1))))
(assoc (tcl-var-set interp var-name result) :result (str count))))))))))))
(define
tcl-cmd-file
@@ -3092,7 +3170,6 @@
((i (tcl-register i "tell" tcl-cmd-tell)))
(let
((i (tcl-register i "flush" tcl-cmd-flush)))
(tcl-register
i
"file"
tcl-cmd-file))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
(let ((i (tcl-register i "file" tcl-cmd-file)))
(let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
(tcl-register i "regsub" tcl-cmd-regsub))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))