698 lines
25 KiB
Scheme
698 lines
25 KiB
Scheme
;pregexp.ss
|
|
;Portable regular expressions for Scheme
|
|
;Dorai Sitaram
|
|
;http://www.ccs.neu.edu/~dorai/pregexp/pregexp.html
|
|
|
|
(module pregexp mzscheme
|
|
(provide pregexp
|
|
pregexp-match-positions
|
|
pregexp-match
|
|
pregexp-split
|
|
pregexp-replace
|
|
pregexp-replace*
|
|
pregexp-quote
|
|
*pregexp-comment-char*)
|
|
|
|
;Configured for Scheme dialect plt by scmxlate, v 2004-09-08,
|
|
;(c) Dorai Sitaram,
|
|
;http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html
|
|
|
|
(define *pregexp-version* 20050502)
|
|
|
|
(define *pregexp-comment-char* #\;)
|
|
|
|
(define *pregexp-space-sensitive?* #t)
|
|
|
|
(define pregexp-error
|
|
(lambda whatever
|
|
(display "Error:")
|
|
(for-each (lambda (x) (display #\space) (write x)) whatever)
|
|
(newline)
|
|
(error "pregexp-error")))
|
|
|
|
(define pregexp-read-pattern
|
|
(lambda (s i n)
|
|
(if (>= i n)
|
|
(list (list ':or (list ':seq)) i)
|
|
(let loop ((branches '()) (i i))
|
|
(if (or (>= i n) (char=? (string-ref s i) #\)))
|
|
(list (cons ':or (reverse! branches)) i)
|
|
(let ((vv
|
|
(pregexp-read-branch
|
|
s
|
|
(if (char=? (string-ref s i) #\|) (+ i 1) i)
|
|
n)))
|
|
(loop (cons (car vv) branches) (cadr vv))))))))
|
|
|
|
(define pregexp-read-branch
|
|
(lambda (s i n)
|
|
(let loop ((pieces '()) (i i))
|
|
(cond
|
|
((>= i n) (list (cons ':seq (reverse! pieces)) i))
|
|
((let ((c (string-ref s i))) (or (char=? c #\|) (char=? c #\))))
|
|
(list (cons ':seq (reverse! pieces)) i))
|
|
(else
|
|
(let ((vv (pregexp-read-piece s i n)))
|
|
(loop (cons (car vv) pieces) (cadr vv))))))))
|
|
|
|
(define pregexp-read-piece
|
|
(lambda (s i n)
|
|
(let ((c (string-ref s i)))
|
|
(case c
|
|
((#\^) (list ':bos (+ i 1)))
|
|
((#\$) (list ':eos (+ i 1)))
|
|
((#\.) (pregexp-wrap-quantifier-if-any (list ':any (+ i 1)) s n))
|
|
((#\[)
|
|
(let ((i+1 (+ i 1)))
|
|
(pregexp-wrap-quantifier-if-any
|
|
(case (and (< i+1 n) (string-ref s i+1))
|
|
((#\^)
|
|
(let ((vv (pregexp-read-char-list s (+ i 2) n)))
|
|
(list (list ':neg-char (car vv)) (cadr vv))))
|
|
(else (pregexp-read-char-list s i+1 n)))
|
|
s
|
|
n)))
|
|
((#\()
|
|
(pregexp-wrap-quantifier-if-any
|
|
(pregexp-read-subpattern s (+ i 1) n)
|
|
s
|
|
n))
|
|
((#\\)
|
|
(pregexp-wrap-quantifier-if-any
|
|
(cond
|
|
((pregexp-read-escaped-number s i n)
|
|
=>
|
|
(lambda (num-i) (list (list ':backref (car num-i)) (cadr num-i))))
|
|
((pregexp-read-escaped-char s i n)
|
|
=>
|
|
(lambda (char-i) (list (car char-i) (cadr char-i))))
|
|
(else (pregexp-error 'pregexp-read-piece 'backslash)))
|
|
s
|
|
n))
|
|
(else
|
|
(if (or *pregexp-space-sensitive?*
|
|
(and (not (char-whitespace? c))
|
|
(not (char=? c *pregexp-comment-char*))))
|
|
(pregexp-wrap-quantifier-if-any (list c (+ i 1)) s n)
|
|
(let loop ((i i) (in-comment? #f))
|
|
(if (>= i n)
|
|
(list ':empty i)
|
|
(let ((c (string-ref s i)))
|
|
(cond
|
|
(in-comment? (loop (+ i 1) (not (char=? c #\newline))))
|
|
((char-whitespace? c) (loop (+ i 1) #f))
|
|
((char=? c *pregexp-comment-char*) (loop (+ i 1) #t))
|
|
(else (list ':empty i))))))))))))
|
|
|
|
(define pregexp-read-escaped-number
|
|
(lambda (s i n)
|
|
(and (< (+ i 1) n)
|
|
(let ((c (string-ref s (+ i 1))))
|
|
(and (char-numeric? c)
|
|
(let loop ((i (+ i 2)) (r (list c)))
|
|
(if (>= i n)
|
|
(list (string->number (list->string (reverse! r))) i)
|
|
(let ((c (string-ref s i)))
|
|
(if (char-numeric? c)
|
|
(loop (+ i 1) (cons c r))
|
|
(list
|
|
(string->number (list->string (reverse! r)))
|
|
i))))))))))
|
|
|
|
(define pregexp-read-escaped-char
|
|
(lambda (s i n)
|
|
(and (< (+ i 1) n)
|
|
(let ((c (string-ref s (+ i 1))))
|
|
(case c
|
|
((#\b) (list ':wbdry (+ i 2)))
|
|
((#\B) (list ':not-wbdry (+ i 2)))
|
|
((#\d) (list ':digit (+ i 2)))
|
|
((#\D) (list '(:neg-char :digit) (+ i 2)))
|
|
((#\n) (list #\newline (+ i 2)))
|
|
((#\r) (list #\return (+ i 2)))
|
|
((#\s) (list ':space (+ i 2)))
|
|
((#\S) (list '(:neg-char :space) (+ i 2)))
|
|
((#\t) (list #\tab (+ i 2)))
|
|
((#\w) (list ':word (+ i 2)))
|
|
((#\W) (list '(:neg-char :word) (+ i 2)))
|
|
(else (list c (+ i 2))))))))
|
|
|
|
(define pregexp-read-posix-char-class
|
|
(lambda (s i n)
|
|
(let ((neg? #f))
|
|
(let loop ((i i) (r (list #\:)))
|
|
(if (>= i n)
|
|
(pregexp-error 'pregexp-read-posix-char-class)
|
|
(let ((c (string-ref s i)))
|
|
(cond
|
|
((char=? c #\^) (set! neg? #t) (loop (+ i 1) r))
|
|
((char-alphabetic? c) (loop (+ i 1) (cons c r)))
|
|
((char=? c #\:)
|
|
(if (or (>= (+ i 1) n) (not (char=? (string-ref s (+ i 1)) #\])))
|
|
(pregexp-error 'pregexp-read-posix-char-class)
|
|
(let ((posix-class
|
|
(string->symbol (list->string (reverse! r)))))
|
|
(list
|
|
(if neg? (list ':neg-char posix-class) posix-class)
|
|
(+ i 2)))))
|
|
(else (pregexp-error 'pregexp-read-posix-char-class)))))))))
|
|
|
|
(define pregexp-read-cluster-type
|
|
(lambda (s i n)
|
|
(let ((c (string-ref s i)))
|
|
(case c
|
|
((#\?)
|
|
(let ((i (+ i 1)))
|
|
(case (string-ref s i)
|
|
((#\:) (list '() (+ i 1)))
|
|
((#\=) (list '(:lookahead) (+ i 1)))
|
|
((#\!) (list '(:neg-lookahead) (+ i 1)))
|
|
((#\>) (list '(:no-backtrack) (+ i 1)))
|
|
((#\<)
|
|
(list
|
|
(case (string-ref s (+ i 1))
|
|
((#\=) '(:lookbehind))
|
|
((#\!) '(:neg-lookbehind))
|
|
(else (pregexp-error 'pregexp-read-cluster-type)))
|
|
(+ i 2)))
|
|
(else
|
|
(let loop ((i i) (r '()) (inv? #f))
|
|
(let ((c (string-ref s i)))
|
|
(case c
|
|
((#\-) (loop (+ i 1) r #t))
|
|
((#\i)
|
|
(loop
|
|
(+ i 1)
|
|
(cons (if inv? ':case-sensitive ':case-insensitive) r)
|
|
#f))
|
|
((#\x)
|
|
(set! *pregexp-space-sensitive?* inv?)
|
|
(loop (+ i 1) r #f))
|
|
((#\:) (list r (+ i 1)))
|
|
(else (pregexp-error 'pregexp-read-cluster-type)))))))))
|
|
(else (list '(:sub) i))))))
|
|
|
|
(define pregexp-read-subpattern
|
|
(lambda (s i n)
|
|
(let* ((remember-space-sensitive? *pregexp-space-sensitive?*)
|
|
(ctyp-i (pregexp-read-cluster-type s i n))
|
|
(ctyp (car ctyp-i))
|
|
(i (cadr ctyp-i))
|
|
(vv (pregexp-read-pattern s i n)))
|
|
(set! *pregexp-space-sensitive?* remember-space-sensitive?)
|
|
(let ((vv-re (car vv)) (vv-i (cadr vv)))
|
|
(if (and (< vv-i n) (char=? (string-ref s vv-i) #\)))
|
|
(list
|
|
(let loop ((ctyp ctyp) (re vv-re))
|
|
(if (null? ctyp) re (loop (cdr ctyp) (list (car ctyp) re))))
|
|
(+ vv-i 1))
|
|
(pregexp-error 'pregexp-read-subpattern))))))
|
|
|
|
(define pregexp-wrap-quantifier-if-any
|
|
(lambda (vv s n)
|
|
(let ((re (car vv)))
|
|
(let loop ((i (cadr vv)))
|
|
(if (>= i n)
|
|
vv
|
|
(let ((c (string-ref s i)))
|
|
(if (and (char-whitespace? c) (not *pregexp-space-sensitive?*))
|
|
(loop (+ i 1))
|
|
(case c
|
|
((#\* #\+ #\? #\{)
|
|
(let* ((new-re
|
|
(list ':between 'minimal? 'at-least 'at-most re))
|
|
(new-vv (list new-re 'next-i)))
|
|
(case c
|
|
((#\*)
|
|
(set-car! (cddr new-re) 0)
|
|
(set-car! (cdddr new-re) #f))
|
|
((#\+)
|
|
(set-car! (cddr new-re) 1)
|
|
(set-car! (cdddr new-re) #f))
|
|
((#\?)
|
|
(set-car! (cddr new-re) 0)
|
|
(set-car! (cdddr new-re) 1))
|
|
((#\{)
|
|
(let ((pq (pregexp-read-nums s (+ i 1) n)))
|
|
(if (not pq)
|
|
(pregexp-error
|
|
'pregexp-wrap-quantifier-if-any
|
|
'left-brace-must-be-followed-by-number))
|
|
(set-car! (cddr new-re) (car pq))
|
|
(set-car! (cdddr new-re) (cadr pq))
|
|
(set! i (caddr pq)))))
|
|
(let loop ((i (+ i 1)))
|
|
(if (>= i n)
|
|
(begin
|
|
(set-car! (cdr new-re) #f)
|
|
(set-car! (cdr new-vv) i))
|
|
(let ((c (string-ref s i)))
|
|
(cond
|
|
((and (char-whitespace? c)
|
|
(not *pregexp-space-sensitive?*))
|
|
(loop (+ i 1)))
|
|
((char=? c #\?)
|
|
(set-car! (cdr new-re) #t)
|
|
(set-car! (cdr new-vv) (+ i 1)))
|
|
(else
|
|
(set-car! (cdr new-re) #f)
|
|
(set-car! (cdr new-vv) i))))))
|
|
new-vv))
|
|
(else vv)))))))))
|
|
|
|
(define pregexp-read-nums
|
|
(lambda (s i n)
|
|
(let loop ((p '()) (q '()) (k i) (reading 1))
|
|
(if (>= k n) (pregexp-error 'pregexp-read-nums))
|
|
(let ((c (string-ref s k)))
|
|
(cond
|
|
((char-numeric? c)
|
|
(if (= reading 1)
|
|
(loop (cons c p) q (+ k 1) 1)
|
|
(loop p (cons c q) (+ k 1) 2)))
|
|
((and (char-whitespace? c) (not *pregexp-space-sensitive?*))
|
|
(loop p q (+ k 1) reading))
|
|
((and (char=? c #\,) (= reading 1)) (loop p q (+ k 1) 2))
|
|
((char=? c #\})
|
|
(let ((p (string->number (list->string (reverse! p))))
|
|
(q (string->number (list->string (reverse! q)))))
|
|
(cond
|
|
((and (not p) (= reading 1)) (list 0 #f k))
|
|
((= reading 1) (list p p k))
|
|
(else (list p q k)))))
|
|
(else #f))))))
|
|
|
|
(define pregexp-invert-char-list
|
|
(lambda (vv) (set-car! (car vv) ':none-of-chars) vv))
|
|
|
|
(define pregexp-read-char-list
|
|
(lambda (s i n)
|
|
(let loop ((r '()) (i i))
|
|
(if (>= i n)
|
|
(pregexp-error 'pregexp-read-char-list 'character-class-ended-too-soon)
|
|
(let ((c (string-ref s i)))
|
|
(case c
|
|
((#\])
|
|
(if (null? r)
|
|
(loop (cons c r) (+ i 1))
|
|
(list (cons ':one-of-chars (reverse! r)) (+ i 1))))
|
|
((#\\)
|
|
(let ((char-i (pregexp-read-escaped-char s i n)))
|
|
(if char-i
|
|
(loop (cons (car char-i) r) (cadr char-i))
|
|
(pregexp-error 'pregexp-read-char-list 'backslash))))
|
|
((#\-)
|
|
(if (or (null? r)
|
|
(let ((i+1 (+ i 1)))
|
|
(and (< i+1 n) (char=? (string-ref s i+1) #\]))))
|
|
(loop (cons c r) (+ i 1))
|
|
(let ((c-prev (car r)))
|
|
(if (char? c-prev)
|
|
(loop
|
|
(cons
|
|
(list ':char-range c-prev (string-ref s (+ i 1)))
|
|
(cdr r))
|
|
(+ i 2))
|
|
(loop (cons c r) (+ i 1))))))
|
|
((#\[)
|
|
(if (char=? (string-ref s (+ i 1)) #\:)
|
|
(let ((posix-char-class-i
|
|
(pregexp-read-posix-char-class s (+ i 2) n)))
|
|
(loop
|
|
(cons (car posix-char-class-i) r)
|
|
(cadr posix-char-class-i)))
|
|
(loop (cons c r) (+ i 1))))
|
|
(else (loop (cons c r) (+ i 1)))))))))
|
|
|
|
(define pregexp-string-match
|
|
(lambda (s1 s i n sk fk)
|
|
(let ((n1 (string-length s1)))
|
|
(if (> n1 n)
|
|
(fk)
|
|
(let loop ((j 0) (k i))
|
|
(cond
|
|
((>= j n1) (sk k))
|
|
((>= k n) (fk))
|
|
((char=? (string-ref s1 j) (string-ref s k)) (loop (+ j 1) (+ k 1)))
|
|
(else (fk))))))))
|
|
|
|
(define pregexp-char-word?
|
|
(lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_))))
|
|
|
|
(define pregexp-at-word-boundary?
|
|
(lambda (s i n)
|
|
(or (= i 0)
|
|
(>= i n)
|
|
(let ((c/i (string-ref s i)) (c/i-1 (string-ref s (- i 1))))
|
|
(let ((c/i/w? (pregexp-check-if-in-char-class? c/i ':word))
|
|
(c/i-1/w? (pregexp-check-if-in-char-class? c/i-1 ':word)))
|
|
(or (and c/i/w? (not c/i-1/w?)) (and (not c/i/w?) c/i-1/w?)))))))
|
|
|
|
(define pregexp-check-if-in-char-class?
|
|
(lambda (c char-class)
|
|
(case char-class
|
|
((:any) (not (char=? c #\newline)))
|
|
((:alnum) (or (char-alphabetic? c) (char-numeric? c)))
|
|
((:alpha) (char-alphabetic? c))
|
|
((:ascii) (< (char->integer c) 128))
|
|
((:blank) (or (char=? c #\space) (char=? c #\tab)))
|
|
((:cntrl) (< (char->integer c) 32))
|
|
((:digit) (char-numeric? c))
|
|
((:graph) (and (>= (char->integer c) 32) (not (char-whitespace? c))))
|
|
((:lower) (char-lower-case? c))
|
|
((:print) (>= (char->integer c) 32))
|
|
((:punct)
|
|
(and (>= (char->integer c) 32)
|
|
(not (char-whitespace? c))
|
|
(not (char-alphabetic? c))
|
|
(not (char-numeric? c))))
|
|
((:space) (char-whitespace? c))
|
|
((:upper) (char-upper-case? c))
|
|
((:word) (or (char-alphabetic? c) (char-numeric? c) (char=? c #\_)))
|
|
((:xdigit)
|
|
(or (char-numeric? c)
|
|
(char-ci=? c #\a)
|
|
(char-ci=? c #\b)
|
|
(char-ci=? c #\c)
|
|
(char-ci=? c #\d)
|
|
(char-ci=? c #\e)
|
|
(char-ci=? c #\f)))
|
|
(else (pregexp-error 'pregexp-check-if-in-char-class?)))))
|
|
|
|
(define pregexp-list-ref
|
|
(lambda (s i)
|
|
(let loop ((s s) (k 0))
|
|
(cond ((null? s) #f) ((= k i) (car s)) (else (loop (cdr s) (+ k 1)))))))
|
|
|
|
(define pregexp-make-backref-list
|
|
(lambda (re)
|
|
(let sub ((re re))
|
|
(if (pair? re)
|
|
(let ((car-re (car re)) (sub-cdr-re (sub (cdr re))))
|
|
(if (eqv? car-re ':sub)
|
|
(cons (cons re #f) sub-cdr-re)
|
|
(append (sub car-re) sub-cdr-re)))
|
|
'()))))
|
|
|
|
(define pregexp-match-positions-aux
|
|
(lambda (re s sn start n i)
|
|
(let ((identity (lambda (x) x))
|
|
(backrefs (pregexp-make-backref-list re))
|
|
(case-sensitive? #t))
|
|
(let sub ((re re) (i i) (sk identity) (fk (lambda () #f)))
|
|
(cond
|
|
((eqv? re ':bos) (if (= i start) (sk i) (fk)))
|
|
((eqv? re ':eos) (if (>= i n) (sk i) (fk)))
|
|
((eqv? re ':empty) (sk i))
|
|
((eqv? re ':wbdry) (if (pregexp-at-word-boundary? s i n) (sk i) (fk)))
|
|
((eqv? re ':not-wbdry)
|
|
(if (pregexp-at-word-boundary? s i n) (fk) (sk i)))
|
|
((and (char? re) (< i n))
|
|
(if ((if case-sensitive? char=? char-ci=?) (string-ref s i) re)
|
|
(sk (+ i 1))
|
|
(fk)))
|
|
((and (not (pair? re)) (< i n))
|
|
(if (pregexp-check-if-in-char-class? (string-ref s i) re)
|
|
(sk (+ i 1))
|
|
(fk)))
|
|
((and (pair? re) (eqv? (car re) ':char-range) (< i n))
|
|
(let ((c (string-ref s i)))
|
|
(if (let ((c< (if case-sensitive? char<=? char-ci<=?)))
|
|
(and (c< (cadr re) c) (c< c (caddr re))))
|
|
(sk (+ i 1))
|
|
(fk))))
|
|
((pair? re)
|
|
(case (car re)
|
|
((:char-range)
|
|
(if (>= i n) (fk) (pregexp-error 'pregexp-match-positions-aux)))
|
|
((:one-of-chars)
|
|
(if (>= i n)
|
|
(fk)
|
|
(let loup-one-of-chars ((chars (cdr re)))
|
|
(if (null? chars)
|
|
(fk)
|
|
(sub
|
|
(car chars)
|
|
i
|
|
sk
|
|
(lambda () (loup-one-of-chars (cdr chars))))))))
|
|
((:neg-char)
|
|
(if (>= i n)
|
|
(fk)
|
|
(sub (cadr re) i (lambda (i1) (fk)) (lambda () (sk (+ i 1))))))
|
|
((:seq)
|
|
(let loup-seq ((res (cdr re)) (i i))
|
|
(if (null? res)
|
|
(sk i)
|
|
(sub (car res) i (lambda (i1) (loup-seq (cdr res) i1)) fk))))
|
|
((:or)
|
|
(let loup-or ((res (cdr re)))
|
|
(if (null? res)
|
|
(fk)
|
|
(sub
|
|
(car res)
|
|
i
|
|
(lambda (i1) (or (sk i1) (loup-or (cdr res))))
|
|
(lambda () (loup-or (cdr res)))))))
|
|
((:backref)
|
|
(let* ((c (pregexp-list-ref backrefs (cadr re)))
|
|
(backref
|
|
(cond
|
|
(c => cdr)
|
|
(else
|
|
(pregexp-error
|
|
'pregexp-match-positions-aux
|
|
'non-existent-backref
|
|
re)
|
|
#f))))
|
|
(if backref
|
|
(pregexp-string-match
|
|
(substring s (car backref) (cdr backref))
|
|
s
|
|
i
|
|
n
|
|
(lambda (i) (sk i))
|
|
fk)
|
|
(sk i))))
|
|
((:sub)
|
|
(sub
|
|
(cadr re)
|
|
i
|
|
(lambda (i1) (set-cdr! (assv re backrefs) (cons i i1)) (sk i1))
|
|
fk))
|
|
((:lookahead)
|
|
(let ((found-it? (sub (cadr re) i identity (lambda () #f))))
|
|
(if found-it? (sk i) (fk))))
|
|
((:neg-lookahead)
|
|
(let ((found-it? (sub (cadr re) i identity (lambda () #f))))
|
|
(if found-it? (fk) (sk i))))
|
|
((:lookbehind)
|
|
(let ((n-actual n) (sn-actual sn))
|
|
(set! n i)
|
|
(set! sn i)
|
|
(let ((found-it?
|
|
(sub
|
|
(list ':seq '(:between #f 0 #f :any) (cadr re) ':eos)
|
|
0
|
|
identity
|
|
(lambda () #f))))
|
|
(set! n n-actual)
|
|
(set! sn sn-actual)
|
|
(if found-it? (sk i) (fk)))))
|
|
((:neg-lookbehind)
|
|
(let ((n-actual n) (sn-actual sn))
|
|
(set! n i)
|
|
(set! sn i)
|
|
(let ((found-it?
|
|
(sub
|
|
(list ':seq '(:between #f 0 #f :any) (cadr re) ':eos)
|
|
0
|
|
identity
|
|
(lambda () #f))))
|
|
(set! n n-actual)
|
|
(set! sn sn-actual)
|
|
(if found-it? (fk) (sk i)))))
|
|
((:no-backtrack)
|
|
(let ((found-it? (sub (cadr re) i identity (lambda () #f))))
|
|
(if found-it? (sk found-it?) (fk))))
|
|
((:case-sensitive :case-insensitive)
|
|
(let ((old case-sensitive?))
|
|
(set! case-sensitive? (eqv? (car re) ':case-sensitive))
|
|
(sub
|
|
(cadr re)
|
|
i
|
|
(lambda (i1) (set! case-sensitive? old) (sk i1))
|
|
(lambda () (set! case-sensitive? old) (fk)))))
|
|
((:between)
|
|
(let* ((maximal? (not (cadr re)))
|
|
(p (caddr re))
|
|
(q (cadddr re))
|
|
(could-loop-infinitely? (and maximal? (not q)))
|
|
(re (car (cddddr re))))
|
|
(let loup-p ((k 0) (i i))
|
|
(if (< k p)
|
|
(sub
|
|
re
|
|
i
|
|
(lambda (i1)
|
|
(if (and could-loop-infinitely? (= i1 i))
|
|
(pregexp-error
|
|
'pregexp-match-positions-aux
|
|
'greedy-quantifier-operand-could-be-empty))
|
|
(loup-p (+ k 1) i1))
|
|
fk)
|
|
(let ((q (and q (- q p))))
|
|
(let loup-q ((k 0) (i i))
|
|
(let ((fk (lambda () (sk i))))
|
|
(if (and q (>= k q))
|
|
(fk)
|
|
(if maximal?
|
|
(sub
|
|
re
|
|
i
|
|
(lambda (i1)
|
|
(if (and could-loop-infinitely? (= i1 i))
|
|
(pregexp-error
|
|
'pregexp-match-positions-aux
|
|
'greedy-quantifier-operand-could-be-empty))
|
|
(or (loup-q (+ k 1) i1) (fk)))
|
|
fk)
|
|
(or (fk)
|
|
(sub
|
|
re
|
|
i
|
|
(lambda (i1) (loup-q (+ k 1) i1))
|
|
fk)))))))))))
|
|
(else (pregexp-error 'pregexp-match-positions-aux))))
|
|
((>= i n) (fk))
|
|
(else (pregexp-error 'pregexp-match-positions-aux))))
|
|
(let ((backrefs (map cdr backrefs))) (and (car backrefs) backrefs)))))
|
|
|
|
(define pregexp-replace-aux
|
|
(lambda (str ins n backrefs)
|
|
(let loop ((i 0) (r ""))
|
|
(if (>= i n)
|
|
r
|
|
(let ((c (string-ref ins i)))
|
|
(if (char=? c #\\)
|
|
(let* ((br-i (pregexp-read-escaped-number ins i n))
|
|
(br
|
|
(if br-i
|
|
(car br-i)
|
|
(if (char=? (string-ref ins (+ i 1)) #\&) 0 #f)))
|
|
(i (if br-i (cadr br-i) (if br (+ i 2) (+ i 1)))))
|
|
(if (not br)
|
|
(let ((c2 (string-ref ins i)))
|
|
(loop
|
|
(+ i 1)
|
|
(if (char=? c2 #\$) r (string-append r (string c2)))))
|
|
(loop
|
|
i
|
|
(let ((backref (pregexp-list-ref backrefs br)))
|
|
(if backref
|
|
(string-append
|
|
r
|
|
(substring str (car backref) (cdr backref)))
|
|
r)))))
|
|
(loop (+ i 1) (string-append r (string c)))))))))
|
|
|
|
(define pregexp
|
|
(lambda (s)
|
|
(set! *pregexp-space-sensitive?* #t)
|
|
(list ':sub (car (pregexp-read-pattern s 0 (string-length s))))))
|
|
|
|
(define pregexp-match-positions
|
|
(lambda (pat str . opt-args)
|
|
(cond
|
|
((string? pat) (set! pat (pregexp pat)))
|
|
((pair? pat) #t)
|
|
(else
|
|
(pregexp-error
|
|
'pregexp-match-positions
|
|
'pattern-must-be-compiled-or-string-regexp
|
|
pat)))
|
|
(let* ((str-len (string-length str))
|
|
(start
|
|
(if (null? opt-args)
|
|
0
|
|
(let ((start (car opt-args)))
|
|
(set! opt-args (cdr opt-args))
|
|
start)))
|
|
(end (if (null? opt-args) str-len (car opt-args))))
|
|
(let loop ((i start))
|
|
(and (<= i end)
|
|
(or (pregexp-match-positions-aux pat str str-len start end i)
|
|
(loop (+ i 1))))))))
|
|
|
|
(define pregexp-match
|
|
(lambda (pat str . opt-args)
|
|
(let ((ix-prs (apply pregexp-match-positions pat str opt-args)))
|
|
(and ix-prs
|
|
(map
|
|
(lambda (ix-pr)
|
|
(and ix-pr (substring str (car ix-pr) (cdr ix-pr))))
|
|
ix-prs)))))
|
|
|
|
(define pregexp-split
|
|
(lambda (pat str)
|
|
(let ((n (string-length str)))
|
|
(let loop ((i 0) (r '()) (picked-up-one-undelimited-char? #f))
|
|
(cond
|
|
((>= i n) (reverse! r))
|
|
((pregexp-match-positions pat str i n)
|
|
=>
|
|
(lambda (y)
|
|
(let ((jk (car y)))
|
|
(let ((j (car jk)) (k (cdr jk)))
|
|
(cond
|
|
((= j k) (loop (+ k 1) (cons (substring str i (+ j 1)) r) #t))
|
|
((and (= j i) picked-up-one-undelimited-char?) (loop k r #f))
|
|
(else (loop k (cons (substring str i j) r) #f)))))))
|
|
(else (loop n (cons (substring str i n) r) #f)))))))
|
|
|
|
(define pregexp-replace
|
|
(lambda (pat str ins)
|
|
(let* ((n (string-length str)) (pp (pregexp-match-positions pat str 0 n)))
|
|
(if (not pp)
|
|
str
|
|
(let ((ins-len (string-length ins)) (m-i (caar pp)) (m-n (cdar pp)))
|
|
(string-append
|
|
(substring str 0 m-i)
|
|
(pregexp-replace-aux str ins ins-len pp)
|
|
(substring str m-n n)))))))
|
|
|
|
(define pregexp-replace*
|
|
(lambda (pat str ins)
|
|
(let ((pat (if (string? pat) (pregexp pat) pat))
|
|
(n (string-length str))
|
|
(ins-len (string-length ins)))
|
|
(let loop ((i 0) (r ""))
|
|
(if (>= i n)
|
|
r
|
|
(let ((pp (pregexp-match-positions pat str i n)))
|
|
(if (not pp)
|
|
(if (= i 0) str (string-append r (substring str i n)))
|
|
(loop
|
|
(cdar pp)
|
|
(string-append
|
|
r
|
|
(substring str i (caar pp))
|
|
(pregexp-replace-aux str ins ins-len pp))))))))))
|
|
|
|
(define pregexp-quote
|
|
(lambda (s)
|
|
(let loop ((i (- (string-length s) 1)) (r '()))
|
|
(if (< i 0)
|
|
(list->string r)
|
|
(loop
|
|
(- i 1)
|
|
(let ((c (string-ref s i)))
|
|
(if (memv
|
|
c
|
|
'(#\\ #\. #\? #\* #\+ #\| #\^ #\$ #\[ #\] #\{ #\} #\( #\)))
|
|
(cons #\\ (cons c r))
|
|
(cons c r))))))))
|
|
|
|
|
|
)
|