;;;; pregexp.scm - Portable regular expression library using Dorai Sitaram's PREGEXP package

;Portable regular expressions for Scheme
;Dorai Sitaram
;http://www.ccs.neu.edu/~dorai
;ds26 AT gte.com
;Oct 2, 1999

; (With additions by Felix Winkelmann)


(cond-expand [(not chicken-compile-shared) (declare (unit regex))] [else])

(declare
  (fixnum)
  (disable-interrupts)
  (usual-integrations)
  (hide pregexp-reverse! pregexp-read-pattern pregexp-read-branch
	pregexp-read-piece pregexp-read-escaped-number pregexp-read-escaped-char
	pregexp-read-posix-char-class pregexp-read-cluster-type pregexp-read-subpattern
	pregexp-wrap-quantifier-if-any pregexp-read-nums pregexp-invert-char-list
	pregexp-read-char-list pregexp-string-match pregexp-char-word?
	pregexp-at-word-boundary? pregexp-check-if-in-char-class? pregexp-list-ref
	pregexp-match-positions-aux pregexp-replace-aux
	pregexp-match pregexp-match-positions pregexp-split pregexp-replace pregexp-replace*) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (bound-to-procedure
     ##sys#check-string ##sys#check-exact ##sys#make-pointer ##sys#cons ##sys#size ##sys#slot) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-byte-vector . _) '(##core#undefined)) ) ]
 [else] )

(register-feature! 'regex 'pregexp)


(define-constant *pregexp-comment-char* #\;)
(define-constant *pregexp-return-char* #\return)
(define-constant *pregexp-tab-char* #\tab)

(define *pregexp-space-sensitive?* #t)

(define pregexp-reverse!
  ;the useful reverse! isn't R5RS
  (lambda (s)
    (let loop ((s s) (r '()))
      (if (null? s) r
          (let ((d (cdr s)))
            (set-cdr! s r)
            (loop d s))))))

(define (pregexp-error . args)
  (apply ##sys#error "pregexp-error: " args) )

(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 (pregexp-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 (pregexp-reverse! pieces)) i))
            ((let ((c (string-ref s i)))
               (or (char=? c #\|)
                   (char=? c #\))))
             (list (cons ':seq (pregexp-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))
        ((#\[) (pregexp-wrap-quantifier-if-any
                 (case (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)
    ; s[i] = \
    (and (< (+ i 1) n) ;must have at least something following \
         (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 (pregexp-reverse! r))) i)
                      (let ((c (string-ref s i)))
                        (if (char-numeric? c)
                            (loop (+ i 1) (cons c r))
                            (list (string->number
                                    (list->string (pregexp-reverse! r)))
                              i))))))))))

(define pregexp-read-escaped-char
  (lambda (s i n)
    ; s[i] = \
    (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 *pregexp-return-char* (+ i 2)))
             ((#\s) (list ':space (+ i 2)))
             ((#\S) (list '(:neg-char :space) (+ i 2)))
             ((#\t) (list *pregexp-tab-char* (+ 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)
    ; lbrack, colon already read
    (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 (pregexp-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)
    ; s[i-1] = left-paren
    (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 bracket 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)
    ; s[i-1] = {
    ; returns (p q k) where s[k] = }
    (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 (pregexp-reverse! p))))
                     (q (string->number (list->string (pregexp-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 (pregexp-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"))))
              ((#\-) (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)
    ;too restrictive for Scheme but this
    ;is what \w is in most regexp notations
    (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 *pregexp-tab-char*)))
      ((: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)
    ;like list-ref but returns #f if index is
    ;out of bounds
    (let loop ((s s) (k 0))
      (cond ((null? s) #f)
            ((= k i) (car s))
            (else (loop (cdr s) (+ k 1)))))))

;re is a compiled regexp.  It's a list that can't be
;nil.  pregexp-match-positions-aux returns a 2-elt list whose
;car is the string-index following the matched
;portion and whose cadr contains the submatches.
;The proc returns false if there's no match.

;Am spelling loop- as loup- because these shouldn't
;be translated into CL loops by scm2cl (although
;they are tail-recursive in Scheme)

(define pregexp-match-positions-aux
  (lambda (re s start n i)
    (let ((case-sensitive? #t))
      (let sub ((re re) (i i) (backrefs '()) (sk list) (fk (lambda () #f)))
        ;(printf "sub ~s ~s~%" i re)
        (cond ((eqv? re ':bos)
               (if (= i start) (sk i backrefs) (fk)))
              ((eqv? re ':eos)
               (if (>= i n) (sk i backrefs) (fk)))
              ((eqv? re ':empty)
               (sk i backrefs))
              ((eqv? re ':wbdry)
               (if (pregexp-at-word-boundary? s i n)
                   (sk i backrefs)
                   (fk)))
              ((eqv? re ':not-wbdry)
               (if (pregexp-at-word-boundary? s i n)
                   (fk)
                   (sk i backrefs)))
              ((and (char? re) (< i n))
               (if ((if case-sensitive? char=? char-ci=?)
                    (string-ref s i) re)
                   (sk (+ i 1) backrefs) (fk)))
              ((and (not (pair? re)) (< i n))
               (if (pregexp-check-if-in-char-class?
                     (string-ref s i) re)
                   (sk (+ i 1) backrefs) (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) backrefs) (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 backrefs sk
                              (lambda ()
                                (loup-one-of-chars (cdr chars))))))))
                 ((:neg-char)
                  (if (>= i n) (fk)
                      (sub (cadr re) i backrefs
                        (lambda (i1 backrefs1) (fk))
                        (lambda () (sk (+ i 1) backrefs)))))
                 ((:seq)
                  (let loup-seq ((res (cdr re)) (i i) (backrefs backrefs))
                    (if (null? res) (sk i backrefs)
                        (sub (car res) i backrefs
                          (lambda (i1 backrefs1)
                            (loup-seq (cdr res) i1 backrefs1))
                          fk))))
                 ((:or)
                  (let loup-or ((res (cdr re)))
                    (if (null? res) (fk)
                        (sub (car res) i backrefs
                          (lambda (i1 backrefs1)
                            (or (sk i1 backrefs1)
                                (loup-or (cdr res))))
                          (lambda () (loup-or (cdr res)))))))
                 ((:backref)
                  (let ((backref (pregexp-list-ref backrefs (cadr re))))
                    (if backref
                        (pregexp-string-match
                          (substring s (car backref) (cdr backref))
                          s i n (lambda (i) (sk i backrefs)) fk)
                        (sk i backrefs))))
                 ((:sub)
                  (let* ((sub-backref (cons i i))
                         (backrefs (append backrefs (list sub-backref))))
                    (sub (cadr re) i backrefs
                      (lambda (i1 backrefs1)
                        (set-cdr! sub-backref i1)
                        (sk i1 backrefs1)) fk)))
                 ((:lookahead)
                  (let ((found-it?
                          (sub (cadr re) i backrefs
                            list (lambda () #f))))
                    (if found-it? (sk i backrefs) (fk))))
                 ((:neg-lookahead)
                  (let ((found-it?
                          (sub (cadr re) i backrefs
                            list (lambda () #f))))
                    (if found-it? (fk) (sk i backrefs))))
                 ((:lookbehind)
                  (let ((n-actual n)) (set! n i)
                    (let ((found-it?
                            (sub (list ':seq '(:between #f 0 #f :any)
                                   (cadr re) ':eos) 0 backrefs
                              list (lambda () #f))))
                      (set! n n-actual)
                      (if found-it? (sk i backrefs) (fk)))))
                 ((:neg-lookbehind)
                  (let ((n-actual n)) (set! n i)
                    (let ((found-it?
                            (sub (list ':seq '(:between #f 0 #f :any)
                                   (cadr re) ':eos) 0 backrefs
                              list (lambda () #f))))
                      (set! n n-actual)
                      (if found-it? (fk) (sk i backrefs)))))
                 ((:no-backtrack)
                  (let ((found-it? (sub (cadr re) i backrefs
                                     list (lambda () #f))))
                    (if found-it?
                        (sk (car found-it?) (cadr found-it?))
                        (fk))))
                 ((:case-sensitive :case-insensitive)
                  (let ((old case-sensitive?))
                    (set! case-sensitive?
                      (eqv? (car re) ':case-sensitive))
                    (sub (cadr re) i backrefs
                      (lambda (i1 backrefs1)
                        (set! case-sensitive? old)
                        (sk i1 backrefs1))
                      (lambda ()
                        (set! case-sensitive? old)
                        (fk)))))
                 ((:between)
                  (let* ((maximal? (not (cadr re)))
                         (p (caddr re)) (q (cadddr re))
                         (re (car (cddddr re)))
                         (subpat? (and (pair? re) (eqv? (car re) ':sub))))
                    (let loup-p ((k 0) (i i) (cbackrefs 'no-match-yet))
                      (if (< k p)
                          (sub re i backrefs
                            (lambda (i1 backrefs1)
                              (loup-p (+ k 1) i1 backrefs1))
                            fk)
                          (let ((q (and q (- q p))))
                            (let loup-q ((k 0) (i i) (cbackrefs cbackrefs))
                              (let ((fk (lambda ()
                                          (sk i (if (eqv? cbackrefs
                                                      'no-match-yet)
                                                    (if subpat?
                                                        (append backrefs
                                                          (list #f))
                                                        backrefs)
                                                    cbackrefs)))))
                                (if (and q (>= k q)) (fk)
                                    (if maximal?
                                        (sub re i backrefs
                                          (lambda (i1 backrefs1)
                                            (or (loup-q (+ k 1) i1 backrefs1)
                                                (fk)))
                                          fk)
                                        (or (fk)
                                            (sub re i backrefs
                                              (lambda (i1 backrefs1)
                                                (loup-q (+ k 1) i1 backrefs1))
                                              fk)))))))))))
                 (else (pregexp-error 'pregexp-match-positions-aux))))
              ((>= i n) (fk))
              (else (pregexp-error 'pregexp-match-positions-aux)))))))

(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) ;in case it got corrupted
    (list ':sub (car (pregexp-read-pattern s 0 (string-length s))))))

(define regexp pregexp)
(define (regexp? x) (and (pair? x) (eq? ':sub (##sys#slot x 0))))

(define pregexp-match-positions
  (lambda (pat str . opt-args)
    (let* ((pat (if (string? pat) (pregexp pat) pat))
           (start (if (null? opt-args) 0
                      (let ((start (car opt-args)))
                        (set! opt-args (cdr opt-args))
                        start)))
           (end (if (null? opt-args) (string-length str)
                    (car opt-args))))
      (let loop ((i start))
        (and (<= i end)
             (let ((vv (pregexp-match-positions-aux pat str start end i)))
               (if vv
                   (cadr vv)
                   (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)
    ;split str into substrings, using pat as delimiter
    (let ((n (string-length str)))
      (let loop ((i 0) (r '()) (picked-up-one-undelimited-char? #f))
        (cond ((>= i n) (pregexp-reverse! r))
              ((pregexp-match-positions pat str i n)
               =>
               (lambda (y)
                 (let ((jk (car y)))
                   (let ((j (car jk)) (k (cdr jk)))
                     ;(printf "j = ~a; k = ~a; i = ~a~n" j k i)
                     (cond ((= j k)
                            ;(printf "producing ~s~n" (substring str i (+ j 1)))
                            (loop (+ k 1) 
                                  (cons (substring str i (+ j 1)) r) #t))
                           ((and (= j i) picked-up-one-undelimited-char?)
                            (loop k r #f))
                           (else
                             ;(printf "producing ~s~n" (substring str i j))
                             (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 ""))
        (let ((pp (pregexp-match-positions pat str i n)))
          (if pp
              (loop (cdar pp)
                (string-append r
                  (substring str i (caar pp))
                  (pregexp-replace-aux str ins ins-len pp)))
              (string-append r
                (substring str i n))))))))
    
;eof

;;; Chicken API:

(let ([string-append string-append])
  (define (prep op rx str start)
    (apply op
	   (if (string? rx)
	       (string-append "^" rx "$") 
	       `(:seq :bos ,rx :eos) )
	   str start) )
  (define (prep2 op rx str start)
    (apply op rx str start) )
  (set! string-match (lambda (rx str . start) (prep pregexp-match rx str start)))
  (set! string-match-positions
    (lambda (rx str . start)
      (let ([r (prep pregexp-match-positions rx str start)])
	(and r (map (lambda (p) (list (car p) (cdr p))) r) ) ) ) )
  (set! string-search (lambda (rx str . start) (prep2 pregexp-match rx str start)))
  (set! string-search-positions
    (lambda (rx str . start)
      (let ([r (prep2 pregexp-match-positions rx str start)])
	(and r (map (lambda (p) (list (car p) (cdr p))) r) ) ) ) ) )


;;; Split string into fields:

(define string-split-fields
  (let ([reverse reverse]
	[substring substring]
	[string-search-positions string-search-positions] )
    (lambda (regexp str . mode-and-start)
      (##sys#check-string str 'string-split-fields)
      (let* ([argc (length mode-and-start)]
	     [len (##sys#size str)]
	     [mode (if (fx> argc 0) (car mode-and-start) #t)]
	     [start (if (fx> argc 1) (cadr mode-and-start) 0)] 
	     [fini (case mode
		     [(#:suffix)
		      (lambda (ms start)
			(if (fx< start len)
			    (##sys#error 'string-split-fields "record does not end with suffix" str regexp)
			    (reverse ms) ) ) ]
		     [(#:infix)
		      (lambda (ms start)
			(if (fx>= start len)
			    (reverse ms)
			    (reverse (cons (substring str start len) ms)) ) ) ]
		     [else (lambda (ms start) (reverse ms)) ] ) ]
	     [fetch (case mode
		      [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
		      [else (lambda (start from to) (substring str from to))] ) ] )
	(let loop ([ms '()] [start start])
	  (let ([m (string-search-positions regexp str start)])
	    (if m
		(let* ([mp (##sys#slot m 0)]
		       [from (##sys#slot mp 0)]
		       [to (cadr mp)] )
		  (if (fx= from to)
		      (if (fx= to len)
			  (fini ms start)
			  (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
		      (loop (cons (fetch start from to) ms) to) ) )
		(fini ms start) ) ) ) ) ) ) )


;;; Substitute matching strings:

(define string-substitute
  (let ([substring substring]
	[reverse reverse]
	[make-string make-string]
	[string-search-positions string-search-positions] )
    (lambda (regex subst string . flag)
      (##sys#check-string subst 'string-substitute)
      (let* ([which (if (pair? flag) (car flag) 1)]
	     [substlen (##sys#size subst)]
	     [substlen-1 (fx- substlen 1)]
	     [result '()] 
	     [total 0] )

	(define (push x) 
	  (set! result (cons x result))
	  (set! total (fx+ total (##sys#size x))) )
	
	(define (substitute matches)
	  (let loop ([start 0] [index 0])
	    (if (fx>= index substlen-1)
		(push (if (fx= start 0) subst (substring subst start substlen)))
		(let ([c (##core#inline "C_subchar" subst index)]
		      [index+1 (fx+ index 1)] )
		  (if (char=? c #\\) 
		      (let ([c2 (##core#inline "C_subchar" subst index+1)])
			(if (not (char=? #\\ c2))
			    (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
			      (push (substring subst start index))
			      (push (substring string (car mi) (cadr mi))) 
			      (loop (fx+ index 2) index+1) )
			    (loop start (fx+ index+1 1)) ) )
		      (loop start index+1) ) ) ) ) )

	(define (concatenate strs)
	  (let ([str (make-string total)])
	    (let loop ([ss strs] [index 0])
	      (if (null? ss) 
		  str
		  (let* ([si (car ss)]
			 [len (##sys#size si)] )
		    (##core#inline "C_substring_copy" si str 0 len index)
		    (loop (cdr ss) (fx+ index len)) ) ) ) ) )

	(let loop ([index 0] [count 1])
	  (let ([matches (string-search-positions regex string index)])
	    (cond [matches
		   (let* ([range (car matches)]
			  [upto (cadr range)] )
		     (cond [(or (not (fixnum? which)) (fx= count which))
			    (push (substring string index (car range)))
			    (substitute matches)
			    (loop upto #f) ]
			   [else
			    (push (substring string index upto))
			    (loop upto (fx+ count 1)) ] ) ) ]
		  [else
		   (push (substring string index (##sys#size string)))
		   (concatenate (reverse result)) ] ) ) ) ) ) ) )

(define string-substitute*
  (let ([string-search-positions string-search-positions])
    (lambda (str smap)
      (##sys#check-string str 'string-substitute*)
      (##sys#check-list smap 'string-substitute*)
      (let ([len (##sys#size str)])
	(define (collect i from total fs)
	  (if (fx>= i len)
	      (##sys#fragments->string
	       total
	       (reverse 
		(if (fx> i from) 
		    (cons (##sys#substring str from i) fs)
		    fs) ) )
	      (let loop ([smap smap] [pos len])
		(if (null? smap)
		    (collect pos from (fx+ total (fx- pos i)) fs)
		    (let* ([p (car smap)]
			   [sm (car p)]
			   [st (cdr p)] 
			   [m (string-search-positions sm str i)] 
			   [ma (and m (##sys#slot m 0))] )
		      (if (and ma (fx= i (##sys#slot ma 0)))
			  (let ([i2 (##sys#slot (##sys#slot ma 1) 0)])
			    (when (fx> i from)
			      (set! fs 
				(cons (##sys#substring str from i) fs)) ) 
			    (collect 
			     i2 i2
			     (fx+ total (string-length st))
			     (cons st fs) ) ) 
			  (loop (cdr smap) 
				(if ma 
				    (fxmin pos (##sys#slot ma 0)) 
				    pos) ) ) ) ) ) ) ) 
	(collect 0 0 0 '()) ) ) ) )


;;; Some useful things:

(define pattern->regexp
  (let ([list->string list->string]
	[string->list string->list] )
    (lambda (s)
      (##sys#check-string s 'pattern->regexp)
      (list->string
       (let loop ([cs (string->list s)])
	 (if (null? cs)
	     '()
	     (let ([c (car cs)]
		   [rest (cdr cs)] )
	       (cond [(char=? c #\*) `(#\. #\* ,@(loop rest))]
		     [(char=? c #\?) (cons '#\. (loop rest))]
		     [(or (char-alphabetic? c) (char-numeric? c)) (cons c (loop rest))]
		     [else `(#\\ ,c ,@(loop rest))] ) ) ) ) ) ) ) )

(define grep
  (let ([string-match string-match])
    (lambda (rx lst)
      (##sys#check-list lst 'grep)
      (let loop ([lst lst])
	(if (null? lst)
	    '()
	    (let ([x (car lst)]
		  [r (cdr lst)] )
	      (if (string-match rx x)
		  (cons x (loop r))
		  (loop r) ) ) ) ) ) ) )