scsh-0.6/scsh/rx/re-subst.scm

150 lines
4.7 KiB
Scheme

;;; Substitution ops with regexps
;;; Copyright (c) 1998 by Olin Shivers.
;;; These function have to be in a separate package because they use
;;; the scsh I/O function WRITE-STRING. The rest of the regexp system
;;; has no dependencies on scsh system code, and is defined independently
;;; of scsh -- which scsh, in turn, relies upon: pieces of scsh-level-0
;;; use the regexp basics. So we have to split this code out to avoid
;;; a circular dependency in the modules: scsh-level-0 needs the regexp
;;; package which needs WRITE-STRING, which comes from the regexp package.
(define (regexp-substitute port match . items)
(let* ((str (regexp-match:string match))
(submatches (regexp-match:submatches match))
(range (lambda (item) ; Return start & end of
(cond ((integer? item) ; ITEM's range in STR.
(let ((submatch (vector-ref submatches item)))
(values (match-start submatch)
(match-end submatch))))
((eq? 'pre item) (values 0
(match-start
(vector-ref submatches 0))))
((eq? 'post item) (values (match-end
(vector-ref submatches 0))
(string-length str)))
(else (error "Illegal substitution item."
item
regexp-substitute))))))
(if port
;; Output port case.
(for-each (lambda (item)
(if (string? item) (write-string item port)
(receive (si ei) (range item)
(write-string str port si ei))))
items)
;; Here's the string case. Make two passes -- one to
;; compute the length of the target string, one to fill it in.
(let* ((len (fold (lambda (item i)
(+ i (if (string? item) (string-length item)
(receive (si ei) (range item) (- ei si)))))
0 items))
(ans (make-string len)))
(fold (lambda (item index)
(cond ((string? item)
(string-copy! ans index item)
(+ index (string-length item)))
(else (receive (si ei) (range item)
(string-copy! ans index str si ei)
(+ index (- ei si))))))
0 items)
ans))))
(define (regexp-substitute/global port re str . items)
(let ((str-len (string-length str))
(range (lambda (start submatches item) ; Return start & end of
(cond ((integer? item) ; ITEM's range in STR.
(let ((submatch (vector-ref submatches item)))
(values (match-start submatch)
(match-end submatch))))
((eq? 'pre item)
(values start
(match-start
(vector-ref submatches 0))))
(else (error "Illegal substitution item."
item
regexp-substitute/global)))))
(num-posts (fold (lambda (item count)
(+ count (if (eq? item 'post) 1 0)))
0 items)))
(if (and port (< num-posts 2))
;; Output port case, with zero or one POST items.
(let recur ((start 0))
(if (<= start str-len)
(let ((match (regexp-search re str start)))
(if match
(let* ((submatches (regexp-match:submatches match))
(s (match-start (vector-ref submatches 0)))
(e (match-end (vector-ref submatches 0)))
(empty? (= s e)))
(for-each (lambda (item)
(cond ((string? item) (write-string item port))
((procedure? item) (write-string (item match) port))
((eq? 'post0 item)
(if (and empty? (< s str-len))
(write-char (string-ref str s) port)))
((eq? 'post item)
(recur (if empty? (+ 1 e) e)))
(else (receive (si ei)
(range start submatches item)
(write-string str port si ei)))))
items))
(write-string str port start))))) ; No match.
;; Either we're making a string, or >1 POST.
(let* ((pieces (let recur ((start 0))
(if (> start str-len)
'()
(let ((match (regexp-search re str start))
(cached-post #f))
(if match
(let* ((submatches
(regexp-match:submatches match))
(s (match-start (vector-ref submatches 0)))
(e (match-end (vector-ref submatches 0)))
(empty? (= s e)))
(fold (lambda (item pieces)
(cond ((string? item)
(cons item pieces))
((procedure? item)
(cons (item match) pieces))
((eq? 'post0 item)
(if (and empty? (< s str-len))
(cons (string (string-ref str s))
pieces)
pieces))
((eq? 'post item)
(if (not cached-post)
(set! cached-post
(recur (if empty? (+ e 1) e))))
(append cached-post pieces))
(else (receive (si ei)
(range start submatches item)
(cons (substring str si ei)
pieces)))))
'() items))
;; No match. Return str[start,end].
(list (if (zero? start) str
(substring str start (string-length str)))))))))
(pieces (reverse pieces)))
(if port (for-each (lambda (p) (write-string p port)) pieces)
(apply string-append pieces))))))