;;;; irregex.scm -- IrRegular Expressions
;;
;; Copyright (c) 2005-2010 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; At this moment there was a loud ring at the bell, and I could
;; hear Mrs. Hudson, our landlady, raising her voice in a wail of
;; expostulation and dismay.
;;
;; "By heaven, Holmes," I said, half rising, "I believe that
;; they are really after us."
;;
;; "No, it's not quite so bad as that.  It is the unofficial
;; force, -- the Baker Street irregulars."

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Notes
;;
;; This code should not require any porting - it should work out of
;; the box in any R[45]RS Scheme implementation.  Slight modifications
;; are needed for R6RS (a separate R6RS-compatible version is included
;; in the distribution as irregex-r6rs.scm).
;;
;; The goal of portability makes this code a little clumsy and
;; inefficient.  Future versions will include both cleanup and
;; performance tuning, but you can only go so far while staying
;; portable.  AND-LET*, SRFI-9 records and custom macros would've been
;; nice.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; History
;;
;; 0.8.1: 2010/03/09 - backtracking irregex-match fix and other small fixes
;; 0.8.0: 2010/01/20 - optimizing DFA compilation, adding SRE escapes
;;                     inside PCREs, adding utility SREs
;; 0.7.5: 2009/08/31 - adding irregex-extract and irregex-split
;;                     *-fold copies match data (use *-fold/fast for speed)
;;                     irregex-opt now returns an SRE
;; 0.7.4: 2009/05/14 - empty alternates (or) and empty csets always fail,
;;                     bugfix in default finalizer for irregex-fold/chunked
;; 0.7.3: 2009/04/14 - adding irregex-fold/chunked, minor doc fixes
;; 0.7.2: 2009/02/11 - some bugfixes, much improved documentation
;; 0.7.1: 2008/10/30 - several bugfixes (thanks to Derick Eddington)
;; 0.7.0: 2008/10/20 - support abstract chunked strings
;; 0.6.2: 2008/07/26 - minor bugfixes, allow global disabling of utf8 mode,
;;                     friendlier error messages in parsing, \Q..\E support
;; 0.6.1: 2008/07/21 - added utf8 mode, more utils, bugfixes
;;   0.6: 2008/05/01 - most of PCRE supported
;;   0.5: 2008/04/24 - fully portable R4RS, many PCRE features implemented
;;   0.4: 2008/04/17 - rewriting NFA to use efficient closure compilation,
;;                     normal strings only, but all of the spencer tests pass
;;   0.3: 2008/03/10 - adding DFA converter (normal strings only)
;;   0.2: 2005/09/27 - adding irregex-opt (like elisp's regexp-opt) utility
;;   0.1: 2005/08/18 - simple NFA interpreter over abstract chunked strings

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Data Structures

(define irregex-tag '*irregex-tag*)

(define (make-irregex dfa dfa/search dfa/extract nfa flags
                      submatches lengths names)
  (vector irregex-tag dfa dfa/search dfa/extract nfa flags
          submatches lengths names))

(define (irregex? obj)
  (and (vector? obj)
       (= 9 (vector-length obj))
       (eq? irregex-tag (vector-ref obj 0))))

(define (irregex-dfa x) (vector-ref x 1))
(define (irregex-dfa/search x) (vector-ref x 2))
(define (irregex-dfa/extract x) (vector-ref x 3))
(define (irregex-nfa x) (vector-ref x 4))
(define (irregex-flags x) (vector-ref x 5))
(define (irregex-num-submatches x) (vector-ref x 6))
(define (irregex-lengths x) (vector-ref x 7))
(define (irregex-names x) (vector-ref x 8))

(define (irregex-new-matches irx)
  (make-irregex-match (irregex-num-submatches irx) (irregex-names irx)))

(define (irregex-reset-matches! m)
  (do ((i (- (vector-length m) 1) (- i 1)))
      ((<= i 3) m)
    (vector-set! m i #f)))

(define (irregex-copy-matches m)
  (and (vector? m)
       (let ((r (make-vector (vector-length m))))
         (do ((i (- (vector-length m) 1) (- i 1)))
             ((< i 0) r)
           (vector-set! r i (vector-ref m i))))))

(define irregex-match-tag '*irregex-match-tag*)

(define (irregex-match-data? obj)
  (and (vector? obj)
       (>= (vector-length obj) 11)
       (eq? irregex-match-tag (vector-ref obj 0))))

(define (make-irregex-match count names)
  (let ((res (make-vector (+ (* 4 (+ 2 count)) 4) #f)))
    (vector-set! res 0 irregex-match-tag)
    (vector-set! res 2 names)
    res))

(define (irregex-match-num-submatches m)
  (- (quotient (- (vector-length m) 3) 4) 2))

(define (irregex-match-chunker m)
  (vector-ref m 1))
(define (irregex-match-names m)
  (vector-ref m 2))
(define (irregex-match-chunker-set! m str)
  (vector-set! m 1 str))

(define (%irregex-match-start-chunk m n) (vector-ref m (+ 3 (* n 4))))
(define (%irregex-match-start-index m n) (vector-ref m (+ 4 (* n 4))))
(define (%irregex-match-end-chunk m n)   (vector-ref m (+ 5 (* n 4))))
(define (%irregex-match-end-index m n)   (vector-ref m (+ 6 (* n 4))))

(define (%irregex-match-fail m)
  (vector-ref m (- (vector-length m) 1)))
(define (%irregex-match-fail-set! m x)
  (vector-set! m (- (vector-length m) 1) x))

;; public interface with error checking
(define (irregex-match-start-chunk m n)
  (if (not (irregex-match-valid-index? m n))
      (error "irregex-match-start-chunk: not a valid index" m n))
  (%irregex-match-start-chunk m n))
(define (irregex-match-start-index m n)
  (if (not (irregex-match-valid-index? m n))
      (error "irregex-match-start-index: not a valid index" m n))
  (%irregex-match-start-index m n))
(define (irregex-match-end-chunk m n)
  (if (not (irregex-match-valid-index? m n))
      (error "irregex-match-end-chunk: not a valid index" m n))
  (%irregex-match-end-chunk m n))
(define (irregex-match-end-index m n)
  (if (not (irregex-match-valid-index? m n))
      (error "irregex-match-end-index: not a valid index" m n))
  (%irregex-match-end-index m n))

(define (irregex-match-start-chunk-set! m n start)
  (vector-set! m (+ 3 (* n 4)) start))
(define (irregex-match-start-index-set! m n start)
  (vector-set! m (+ 4 (* n 4)) start))
(define (irregex-match-end-chunk-set! m n end)
  (vector-set! m (+ 5 (* n 4)) end))
(define (irregex-match-end-index-set! m n end)
  (vector-set! m (+ 6 (* n 4)) end))

(define (irregex-match-index m opt)
  (if (pair? opt)
      (cond ((number? (car opt)) (car opt))
            ((assq (car opt) (irregex-match-names m)) => cdr)
            (else (error "unknown match name" (car opt))))
      0))

(define (%irregex-match-valid-index? m n)
  (and (< (+ 3 (* n 4)) (vector-length m))
       (vector-ref m (+ 4 (* n 4)))))

(define (irregex-match-valid-index? m n)
  (if (not (irregex-match-data? m))
      (error "irregex-match-valid-index?: not match data" m))
  (if (not (integer? n))
      (error "irregex-match-valid-index?: not an integer" n))
  (%irregex-match-valid-index? m n))

(define (irregex-match-substring m . opt)
  (if (not (irregex-match-data? m))
      (error "irregex-match-substring: not match data" m))
  (let* ((cnk (irregex-match-chunker m))
         (n (irregex-match-index m opt)))
    (and (%irregex-match-valid-index? m n)
         ((chunker-get-substring cnk)
          (%irregex-match-start-chunk m n)
          (%irregex-match-start-index m n)
          (%irregex-match-end-chunk m n)
          (%irregex-match-end-index m n)))))

(define (irregex-match-subchunk m . opt)
  (if (not (irregex-match-data? m))
      (error "irregex-match-subchunk: not match data" m))
  (let* ((cnk (irregex-match-chunker m))
         (n (irregex-match-index m opt))
         (get-subchunk (chunker-get-subchunk cnk)))
    (if (not get-subchunk)
        (error "this chunk type does not support match subchunks")
        (and (%irregex-match-valid-index? m n)
             (get-subchunk
              (%irregex-match-start-chunk m n)
              (%irregex-match-start-index m n)
              (%irregex-match-end-chunk m n)
              (%irregex-match-end-index m n))))))

;; chunkers tell us how to navigate through chained chunks of strings

(define (make-irregex-chunker get-next get-str . o)
  (let* ((get-start (or (and (pair? o) (car o)) (lambda (cnk) 0)))
         (o (if (pair? o) (cdr o) o))
         (get-end (or (and (pair? o) (car o))
                      (lambda (cnk) (string-length (get-str cnk)))))
         (o (if (pair? o) (cdr o) o))
         (get-substr
          (or (and (pair? o) (car o))
              (lambda (cnk1 start cnk2 end)
                (if (eq? cnk1 cnk2)
                    (substring (get-str cnk1) start end)
                    (let loop ((cnk (get-next cnk1))
                               (res (list (substring (get-str cnk1)
                                                     start
                                                     (get-end cnk1)))))
                      (if (eq? cnk cnk2)
                          (string-cat-reverse
                           (cons (substring (get-str cnk)
                                            (get-start cnk)
                                            end)
                                 res))
                          (loop (get-next cnk)
                                (cons (substring (get-str cnk)
                                                 (get-start cnk)
                                                 (get-end cnk))
                                      res))))))))
         (o (if (pair? o) (cdr o) o))
         (get-subchunk (and (pair? o) (car o))))
    (if (not (and (procedure? get-next) (procedure? get-str)
                  (procedure? get-start) (procedure? get-substr)))
        (error "make-irregex-chunker: expected a procdure"))
    (vector get-next get-str get-start get-end get-substr get-subchunk)))

(define (chunker-get-next cnk) (vector-ref cnk 0))
(define (chunker-get-str cnk) (vector-ref cnk 1))
(define (chunker-get-start cnk) (vector-ref cnk 2))
(define (chunker-get-end cnk) (vector-ref cnk 3))
(define (chunker-get-substring cnk) (vector-ref cnk 4))
(define (chunker-get-subchunk cnk) (vector-ref cnk 5))

(define (chunker-prev-chunk cnk start end)
  (if (eq? start end)
      #f
      (let ((get-next (chunker-get-next cnk)))
        (let lp ((start start))
          (let ((next (get-next start)))
            (if (eq? next end)
                start
                (and next (lp next))))))))

(define (chunker-prev-char cnk start end)
  (let ((prev (chunker-prev-chunk cnk start end)))
    (and prev
         (string-ref ((chunker-get-str cnk) prev)
                     (- ((chunker-get-end cnk) prev) 1)))))

(define (chunker-next-char cnk src)
  (let ((next ((chunker-get-next cnk) src)))
    (and next
         (string-ref ((chunker-get-str cnk) next)
                     ((chunker-get-start cnk) next)))))

(define (chunk-before? cnk a b)
  (and (not (eq? a b))
       (let ((next ((chunker-get-next cnk) a)))
         (and next
              (if (eq? next b)
                  #t
                  (chunk-before? cnk next b))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; String Utilities

;; Unicode version (skip surrogates)
(define *all-chars*
  `(/ ,(integer->char 0) ,(integer->char #xD7FF)
      ,(integer->char #xE000) ,(integer->char #x10FFFF)))

;; ASCII version, offset to not assume 0-255
;; (define *all-chars* `(/ ,(integer->char (- (char->integer #\space) 32)) ,(integer->char (+ (char->integer #\space) 223))))

;; set to #f to ignore even an explicit request for utf8 handling
(define *allow-utf8-mode?* #t)

;; (define *named-char-properties* '())

(define (string-scan-char str c . o)
  (let ((end (string-length str)))
    (let scan ((i (if (pair? o) (car o) 0)))
      (cond ((= i end) #f)
            ((eqv? c (string-ref str i)) i)
            (else (scan (+ i 1)))))))

(define (string-scan-char-escape str c . o)
  (let ((end (string-length str)))
    (let scan ((i (if (pair? o) (car o) 0)))
      (cond ((= i end) #f)
            ((eqv? c (string-ref str i)) i)
            ((eqv? c #\\) (scan (+ i 2)))
            (else (scan (+ i 1)))))))

(define (string-scan-pred str pred . o)
  (let ((end (string-length str)))
    (let scan ((i (if (pair? o) (car o) 0)))
      (cond ((= i end) #f)
            ((pred (string-ref str i)) i)
            (else (scan (+ i 1)))))))

(define (string-split-char str c)
  (let ((end (string-length str)))
    (let lp ((i 0) (from 0) (res '()))
      (define (collect) (cons (substring str from i) res))
      (cond ((>= i end) (reverse (collect)))
            ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
            (else (lp (+ i 1) from res))))))

(define (char-alphanumeric? c)
  (or (char-alphabetic? c) (char-numeric? c)))

(define (%substring=? a b start1 start2 len)
  (let lp ((i 0))
    (cond ((>= i len)
           #t)
          ((char=? (string-ref a (+ start1 i)) (string-ref b (+ start2 i)))
           (lp (+ i 1)))
          (else
           #f))))

;; SRFI-13 extracts

(define (%%string-copy! to tstart from fstart fend)
  (do ((i fstart (+ i 1))
       (j tstart (+ j 1)))
      ((>= i fend))
    (string-set! to j (string-ref from i))))

(define (string-cat-reverse string-list)
  (string-cat-reverse/aux
   (fold (lambda (s a) (+ (string-length s) a)) 0 string-list)
   string-list))

(define (string-cat-reverse/aux len string-list)
  (let ((res (make-string len)))
    (let lp ((i len) (ls string-list))
      (if (pair? ls)
	  (let* ((s (car ls))
		 (slen (string-length s))
		 (i (- i slen)))
	    (%%string-copy! res i s 0 slen)
	    (lp i (cdr ls)))))
    res))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; List Utilities

;; like the one-arg IOTA case
(define (zero-to n)
  (if (<= n 0)
      '()
      (let lp ((i (- n 1)) (res '()))
        (if (zero? i) (cons 0 res) (lp (- i 1) (cons i res))))))

;; take the head of list FROM up to but not including TO, which must
;; be a tail of the list
(define (take-up-to from to)
  (let lp ((ls from) (res '()))
    (if (and (pair? ls) (not (eq? ls to)))
        (lp (cdr ls) (cons (car ls) res))
        (reverse res))))

;; SRFI-1 extracts (simplified 1-ary versions)

(define (find pred ls)
  (cond ((find-tail pred ls) => car)
	(else #f)))

(define (find-tail pred ls)
  (let lp ((ls ls))
    (cond ((null? ls) #f)
          ((pred (car ls)) ls)
          (else (lp (cdr ls))))))

(define (last ls)
  (if (not (pair? ls))
      (error "can't take last of empty list" ls)
      (let lp ((ls ls))
        (if (pair? (cdr ls))
            (lp (cdr ls))
            (car ls)))))

(define (any pred ls)
  (and (pair? ls)
       (let lp ((head (car ls)) (tail (cdr ls)))
         (if (null? tail)
             (pred head)
             (or (pred head) (lp (car tail) (cdr tail)))))))

(define (every pred ls)
  (or (null? ls)
      (let lp ((head (car ls))  (tail (cdr ls)))
        (if (null? tail)
            (pred head)
            (and (pred head) (lp (car tail) (cdr tail)))))))

(define (fold kons knil ls)
  (let lp ((ls ls) (res knil))
    (if (null? ls)
        res
        (lp (cdr ls) (kons (car ls) res)))))

(define (filter pred ls)
  (let lp ((ls ls) (res '()))
    (if (null? ls)
        (reverse res)
        (lp (cdr ls) (if (pred (car ls)) (cons (car ls) res) res)))))

(define (remove pred ls)
  (let lp ((ls ls) (res '()))
    (if (null? ls)
        (reverse res)
        (lp (cdr ls) (if (pred (car ls)) res (cons (car ls) res))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Flags

(define (bit-shr n i)
  (quotient n (expt 2 i)))

(define (bit-shl n i)
  (* n (expt 2 i)))

(define (bit-not n) (- #xFFFF n))

(define (bit-ior a b)
  (cond
   ((zero? a) b)
   ((zero? b) a)
   (else
    (+ (if (or (odd? a) (odd? b)) 1 0)
       (* 2 (bit-ior (quotient a 2) (quotient b 2)))))))

(define (bit-and a b)
  (cond
   ((zero? a) 0)
   ((zero? b) 0)
   (else
    (+ (if (and (odd? a) (odd? b)) 1 0)
       (* 2 (bit-and (quotient a 2) (quotient b 2)))))))

(define (integer-log n)
  (define (b8 n r)
    (if (>= n (bit-shl 1 8)) (b4 (bit-shr n 8) (+ r 8)) (b4 n r)))
  (define (b4 n r)
    (if (>= n (bit-shl 1 4)) (b2 (bit-shr n 4) (+ r 4)) (b2 n r)))
  (define (b2 n r)
    (if (>= n (bit-shl 1 2)) (b1 (bit-shr n 2) (+ r 2)) (b1 n r)))
  (define (b1 n r) (if (>= n (bit-shl 1 1)) (+ r 1) r))
  (if (>= n (bit-shl 1 16)) (b8 (bit-shr n 16) 16) (b8 n 0)))

(define (flag-set? flags i)
  (= i (bit-and flags i)))
(define (flag-join a b)
  (if b (bit-ior a b) a))
(define (flag-clear a b)
  (bit-and a (bit-not b)))

(define ~none 0)
(define ~searcher? 1)
(define ~consumer? 2)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Parsing Embedded SREs in PCRE Strings

;; (define (with-read-from-string str i proc)
;;   (define (port-size in)
;;     (let lp ((i 0)) (if (eof-object? (read-char in)) i (lp (+ i 1)))))
;;   (let* ((len (string-length str))
;;          (tail-len (- len i))
;;          (in (open-input-string (substring str i len)))
;;          (sre (read in))
;;          (unused-len (port-size in)))
;;     (close-input-port in)
;;     (proc sre (- tail-len unused-len))))

(define close-token (list 'close))
(define dot-token (string->symbol "."))

(define (with-read-from-string str i proc)
  (define end (string-length str))
  (define (read i k)
    (cond
     ((>= i end) (error "unterminated embedded SRE" str))
     (else
      (case (string-ref str i)
        ((#\()
         (let lp ((i (+ i 1)) (ls '()))
           (read
            i
            (lambda (x j)
              (cond
               ((eq? x close-token)
                (k (reverse ls) j))
               ((eq? x dot-token)
                (if (null? ls)
                    (error "bad dotted form" str)
                    (read j (lambda (y j2)
                              (read j2 (lambda (z j3)
                                         (if (not (eq? z close-token))
                                             (error "bad dotted form" str)
                                             (k (append (reverse (cdr ls))
                                                        (cons (car ls) y))
                                                j3))))))))
               (else
                (lp j (cons x ls))))))))
        ((#\))
         (k close-token (+ i 1)))
        ((#\;)
         (let skip ((i (+ i 1)))
           (if (or (>= i end) (eqv? #\newline (string-ref str i)))
               (read (+ i 1) k)
               (skip (+ i 1)))))
        ((#\' #\`)
         (read (+ i 1)
           (lambda (sexp j)
             (let ((q (if (eqv? #\' (string-ref str i)) 'quote 'quasiquote)))
               (k (list q sexp) j)))))
        ((#\,)
         (let* ((at? (and (< (+ i 1) end) (eqv? #\@ (string-ref str (+ i 1)))))
                (u (if at? 'uquote-splicing 'unquote))
                (j (if at? (+ i 2) (+ i 1))))
           (read j (lambda (sexp j) (k (list u sexp) j)))))
        ((#\")
         (let scan ((from (+ i 1)) (i (+ i 1)) (res '()))
           (define (collect)
             (if (= from i) res (cons (substring str from i) res)))
           (if (>= i end)
               (error "unterminated string in embeded SRE" str)
               (case (string-ref str i)
                 ((#\") (k (string-cat-reverse (collect)) (+ i 1)))
                 ((#\\) (scan (+ i 1) (+ i 2) (collect)))
                 (else (scan from (+ i 1) res))))))
        ((#\#)
         (case (string-ref str (+ i 1))
           ((#\;)
            (read (+ i 2) (lambda (sexp j) (read j k))))
           ((#\\)
            (read (+ i 2)
              (lambda (sexp j)
                (k (case sexp
                     ((space) #\space)
                     ((newline) #\newline)
                     (else (let ((s (if (number? sexp)
                                        (number->string sexp)
                                        (symbol->string sexp))))
                             (string-ref s 0))))
                   j))))
           ((#\t #\f)
            (k (eqv? #\t (string-ref str (+ i 1))) (+ i 2)))
           (else
            (error "bad # syntax in simplified SRE" i))))
        (else
         (cond
          ((char-whitespace? (string-ref str i))
           (read (+ i 1) k))
          (else ;; symbol/number
           (let scan ((j (+ i 1)))
             (cond
              ((or (>= j end)
                   (let ((c (string-ref str j)))
                     (or (char-whitespace? c)
                         (memv c '(#\; #\( #\) #\" #\# #\\)))))
               (let ((str2 (substring str i j)))
                 (k (or (string->number str2) (string->symbol str2)) j)))
              (else (scan (+ j 1))))))))))))
  (read i (lambda (res j)
            (if (eq? res 'close-token)
                (error "unexpected ')' in SRE" str j)
                (proc res j)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Parsing PCRE Strings

(define ~save? 1)
(define ~case-insensitive? 2)
(define ~multi-line? 4)
(define ~single-line? 8)
(define ~ignore-space? 16)
(define ~utf8? 32)

(define (symbol-list->flags ls)
  (let lp ((ls ls) (res ~none))
    (if (not (pair? ls))
        res
        (lp (cdr ls)
            (flag-join
             res
             (case (car ls)
               ((i ci case-insensitive) ~case-insensitive?)
               ((m multi-line) ~multi-line?)
               ((s single-line) ~single-line?)
               ((x ignore-space) ~ignore-space?)
               ((u utf8) (if *allow-utf8-mode?* ~utf8? ~none))
               (else #f)))))))

(define (maybe-string->sre obj)
  (if (string? obj) (string->sre obj) obj))

(define (string->sre str . o)
  (if (not (string? str)) (error "string->sre: expected a string" str))
  (let ((end (string-length str))
        (flags (symbol-list->flags o)))

    (let lp ((i 0) (from 0) (flags flags) (res '()) (st '()))

      ;; handle case sensitivity at the literal char/string level
      (define (cased-char ch)
        (if (and (flag-set? flags ~case-insensitive?)
                 (char-alphabetic? ch))
            `(or ,ch ,(char-altcase ch))
            ch))
      (define (cased-string str)
        (if (flag-set? flags ~case-insensitive?)
            (sre-sequence (map cased-char (string->list str)))
            str))
      ;; accumulate the substring from..i as literal text
      (define (collect)
        (if (= i from) res (cons (cased-string (substring str from i)) res)))
      ;; like collect but breaks off the last single character when
      ;; collecting literal data, as the argument to ?/*/+ etc.
      (define (collect/single)
        (let* ((utf8? (flag-set? flags ~utf8?))
               (j (if (and utf8? (> i 1))
                      (utf8-backup-to-initial-char str (- i 1))
                      (- i 1))))
          (cond
           ((< j from)
            res)
           (else
            (let ((c (cased-char (if utf8?
                                     (utf8-string-ref str j (- i j))
                                     (string-ref str j)))))
              (cond
               ((= j from)
                (cons c res))
               (else
                (cons c
                      (cons (cased-string (substring str from j))
                            res)))))))))
      ;; collects for use as a result, reversing and grouping OR
      ;; terms, and some ugly tweaking of `function-like' groups and
      ;; conditionals
      (define (collect/terms)
        (let* ((ls (collect))
               (func
                (and (pair? ls)
                     (memq (last ls)
                           '(atomic if look-ahead neg-look-ahead
                                    look-behind neg-look-behind
                                    => submatch-named
                                    w/utf8 w/noutf8))))
               (prefix (if (and func (memq (car func) '(=> submatch-named)))
                           (list 'submatch-named (cadr (reverse ls)))
                           (and func (list (car func)))))
               (ls (if func
                       (if (memq (car func) '(=> submatch-named))
                           (reverse (cddr (reverse ls)))
                           (reverse (cdr (reverse ls))))
                       ls)))
          (let lp ((ls ls) (term '()) (res '()))
            (define (shift)
              (cons (sre-sequence term) res))
            (cond
             ((null? ls)
              (let* ((res (sre-alternate (shift)))
                     (res (if (flag-set? flags ~save?)
                              (list 'submatch res)
                              res)))
                (if prefix
                    (if (eq? 'if (car prefix))
                        (cond
                         ((not (pair? res))
                          'epsilon)
                         ((memq (car res)
                                '(look-ahead neg-look-ahead
                                             look-behind neg-look-behind))
                          res)
                         ((eq? 'seq (car res))
                          `(if ,(cadr res)
                               ,(if (pair? (cdr res))
                                    (sre-sequence (cddr res))
                                    'epsilon)))
                         (else
                          `(if ,(cadadr res)
                               ,(if (pair? (cdr res))
                                    (sre-sequence (cddadr res))
                                    'epsilon)
                               ,(sre-alternate
                                 (if (pair? (cdr res)) (cddr res) '())))))
                        `(,@prefix ,res))
                    res)))
             ((eq? 'or (car ls)) (lp (cdr ls) '() (shift)))
             (else (lp (cdr ls) (cons (car ls) term) res))))))
      (define (save)
        (cons (cons flags (collect)) st))

      ;; main parsing
      (if (>= i end)
          (if (pair? st)
              (error "unterminated parenthesis in regexp" str)
              (collect/terms))
          (let ((c (string-ref str i)))
            (case c
              ((#\.)
               (lp (+ i 1) (+ i 1) flags
                   (cons (if (flag-set? flags ~single-line?) 'any 'nonl)
                         (collect))
                   st))
              ((#\?)
               (let ((res (collect/single)))
                 (if (null? res)
                     (error "? can't follow empty pattern" str res)
                     (let ((x (car res)))
                       (lp (+ i 1)
                           (+ i 1)
                           flags
                           (cons
                            (if (pair? x)
                                (case (car x)
                                  ((*)  `(*? ,@(cdr x)))
                                  ((+)  `(**? 1 #f ,@(cdr x)))
                                  ((?)  `(?? ,@(cdr x)))
                                  ((**) `(**? ,@(cdr x)))
                                  ((=)  `(**? ,(cadr x) ,@(cdr x)))
                                  ((>=)  `(**? ,(cadr x) #f ,@(cddr x)))
                                  (else `(? ,x)))
                                `(? ,x))
                            (cdr res))
                           st)))))
              ((#\+ #\*)
               (let* ((res (collect/single))
                      (x (if (pair? res) (car res) 'epsilon))
                      (op (string->symbol (string c))))
                 (cond
                  ((sre-repeater? x)
                   (error "duplicate repetition (e.g. **) in pattern" str res))
                  ((sre-empty? x)
                   (error "can't repeat empty pattern (e.g. ()*)" str res))
                  (else
                   (lp (+ i 1) (+ i 1) flags
                       (cons (list op x) (cdr res))
                       st)))))
              ((#\()
               (cond
                ((>= (+ i 1) end)
                 (error "unterminated parenthesis in regexp" str))
                ((not (memv (string-ref str (+ i 1)) '(#\? #\*))) ; normal case
                 (lp (+ i 1) (+ i 1) (flag-join flags ~save?) '() (save)))
                ((>= (+ i 2) end)
                 (error "unterminated parenthesis in regexp" str))
                ((eqv? (string-ref str (+ i 1)) #\*)
                 (if (eqv? #\' (string-ref str (+ i 2)))
                     (with-read-from-string str (+ i 3)
                       (lambda (sre j)
                         (if (or (>= j end) (not (eqv? #\) (string-ref str j))))
                             (error "unterminated (*'...) SRE escape" str)
                             (lp (+ j 1) (+ j 1) flags (cons sre (collect)) st))))
                     (error "bad regexp syntax: (*FOO) not supported" str)))
                (else                   ;; (?...) case
                 (case (string-ref str (+ i 2))
                   ((#\#)
                    (let ((j (string-scan-char str #\) (+ i 3))))
                      (lp (+ j i) (+ j 1) flags (collect) st)))
                   ((#\:)
                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?) '() (save)))
                   ((#\=)
                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
                        '(look-ahead) (save)))
                   ((#\!)
                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
                        '(neg-look-ahead) (save)))
                   ((#\<)
                    (cond
                     ((>= (+ i 3) end)
                      (error "unterminated parenthesis in regexp" str))
                     (else
                      (case (string-ref str (+ i 3))
                        ((#\=)
                         (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
                             '(look-behind) (save)))
                        ((#\!)
                         (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
                             '(neg-look-behind) (save)))
                        (else
                         (let ((j (and (char-alphabetic?
                                        (string-ref str (+ i 3)))
                                       (string-scan-char str #\> (+ i 4)))))
                           (if j
                               (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
                                   `(,(string->symbol (substring str (+ i 3) j))
                                     submatch-named)
                                   (save))
                               (error "invalid (?< sequence" str))))))))
                   ((#\>)
                    (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
                        '(atomic) (save)))
                   ;;((#\' #\P) ; named subpatterns
                   ;; )
                   ;;((#\R) ; recursion
                   ;; )
                   ((#\()
                    (cond
                     ((>= (+ i 3) end)
                      (error "unterminated parenthesis in regexp" str))
                     ((char-numeric? (string-ref str (+ i 3)))
                      (let* ((j (string-scan-char str #\) (+ i 3)))
                             (n (string->number (substring str (+ i 3) j))))
                        (if (not n)
                            (error "invalid conditional reference" str)
                            (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
                                `(,n if) (save)))))
                     ((char-alphabetic? (string-ref str (+ i 3)))
                      (let* ((j (string-scan-char str #\) (+ i 3)))
                             (s (string->symbol (substring str (+ i 3) j))))
                        (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
                            `(,s if) (save))))
                     (else
                      (lp (+ i 2) (+ i 2) (flag-clear flags ~save?)
                          '(if) (save)))))
                   ((#\{)
                    (error "unsupported Perl-style cluster" str))
                   (else
                    (let ((old-flags flags))
                      (let lp2 ((j (+ i 2)) (flags flags) (invert? #f))
                        (define (join x)
                          ((if invert? flag-clear flag-join) flags x))
                        (define (new-res res)
                          (let ((before (flag-set? old-flags ~utf8?))
                                (after (flag-set? flags ~utf8?)))
                            (if (eq? before after)
                                res
                                (cons (if after 'w/utf8 'w/noutf8) res))))
                        (cond
                         ((>= j end)
                          (error "incomplete cluster" str i))
                         (else
                          (case (string-ref str j)
                            ((#\i)
                             (lp2 (+ j 1) (join ~case-insensitive?) invert?))
                            ((#\m)
                             (lp2 (+ j 1) (join ~multi-line?) invert?))
                            ((#\x)
                             (lp2 (+ j 1) (join ~ignore-space?) invert?))
                            ((#\u)
                             (if *allow-utf8-mode?*
                                 (lp2 (+ j 1) (join ~utf8?) invert?)
                                 (lp2 (+ j 1) flags invert?)))
                            ((#\-)
                             (lp2 (+ j 1) flags (not invert?)))
                            ((#\))
                             (lp (+ j 1) (+ j 1) flags (new-res (collect))
                                 st))
                            ((#\:)
                             (lp (+ j 1) (+ j 1) flags (new-res '())
                                 (cons (cons old-flags (collect)) st)))
                            (else
                             (error "unknown regex cluster modifier" str)
                             )))))))))))
              ((#\))
               (if (null? st)
                   (error "too many )'s in regexp" str)
                   (lp (+ i 1)
                       (+ i 1)
                       (caar st)
                       (cons (collect/terms) (cdar st))
                       (cdr st))))
              ((#\[)
               (apply
                (lambda (sre j)
                  (lp (+ j 1) (+ j 1) flags (cons sre (collect)) st))
                (string-parse-cset str (+ i 1) flags)))
              ((#\{)
               (cond
                ((or (>= (+ i 1) end)
                     (not (or (char-numeric? (string-ref str (+ i 1)))
                              (eqv? #\, (string-ref str (+ i 1))))))
                 (lp (+ i 1) from flags res st))
                (else
                 (let ((res (collect/single)))
                   (cond
                    ((null? res)
                     (error "{ can't follow empty pattern"))
                    (else
                     (let* ((x (car res))
                            (tail (cdr res))
                            (j (string-scan-char str #\} (+ i 1)))
                            (s2 (string-split-char (substring str (+ i 1) j)
                                                   #\,))
                            (n (string->number (car s2)))
                            (m (and (pair? (cdr s2))
                                    (string->number (cadr s2)))))
                       (cond
                        ((or (not n)
                             (and (pair? (cdr s2))
                                  (not (equal? "" (cadr s2)))
                                  (not m)))
                         (error "invalid {n} repetition syntax" s2))
                        ((null? (cdr s2))
                         (lp (+ j 1) (+ j 1) flags `((= ,n ,x) ,@tail) st))
                        (m
                         (lp (+ j 1) (+ j 1) flags `((** ,n ,m ,x) ,@tail) st))
                        (else
                         (lp (+ j 1) (+ j 1) flags `((>= ,n ,x) ,@tail) st)
                         )))))))))
              ((#\\)
               (cond
                ((>= (+ i 1) end)
                 (error "incomplete escape sequence" str))
                (else
                 (let ((c (string-ref str (+ i 1))))
                   (case c
                     ((#\d)
                      (lp (+ i 2) (+ i 2) flags `(numeric ,@(collect)) st))
                     ((#\D)
                      (lp (+ i 2) (+ i 2) flags `((~ numeric) ,@(collect)) st))
                     ((#\s)
                      (lp (+ i 2) (+ i 2) flags `(space ,@(collect)) st))
                     ((#\S)
                      (lp (+ i 2) (+ i 2) flags `((~ space) ,@(collect)) st))
                     ((#\w)
                      (lp (+ i 2) (+ i 2) flags
                          `((or alphanumeric ("_")) ,@(collect)) st))
                     ((#\W)
                      (lp (+ i 2) (+ i 2) flags
                          `((~ (or alphanumeric ("_"))) ,@(collect)) st))
                     ((#\b)
                      (lp (+ i 2) (+ i 2) flags
                          `((or bow eow) ,@(collect)) st))
                     ((#\B)
                      (lp (+ i 2) (+ i 2) flags `(nwb ,@(collect)) st))
                     ((#\A)
                      (lp (+ i 2) (+ i 2) flags `(bos ,@(collect)) st))
                     ((#\Z)
                      (lp (+ i 2) (+ i 2) flags
                          `((? #\newline) eos ,@(collect)) st))
                     ((#\z)
                      (lp (+ i 2) (+ i 2) flags `(eos ,@(collect)) st))
                     ((#\R)
                      (lp (+ i 2) (+ i 2) flags `(newline ,@(collect)) st))
                     ((#\K)
                      (lp (+ i 2) (+ i 2) flags `(reset ,@(collect)) st))
                     ;; these two are from Emacs and TRE, but not in PCRE
                     ((#\<)
                      (lp (+ i 2) (+ i 2) flags `(bow ,@(collect)) st))
                     ((#\>)
                      (lp (+ i 2) (+ i 2) flags `(eow ,@(collect)) st))
                     ((#\x)
                      (apply
                       (lambda (ch j)
                         (lp (+ j 1) (+ j 1) flags `(,ch ,@(collect)) st))
                       (string-parse-hex-escape str (+ i 2) end)))
                     ((#\k)
                      (let ((c (string-ref str (+ i 2))))
                        (if (not (memv c '(#\< #\{ #\')))
                            (error "bad \\k usage, expected \\k<...>" str)
                            (let* ((terminal (char-mirror c))
                                   (j (string-scan-char str terminal (+ i 2)))
                                   (s (and j (substring str (+ i 3) j)))
                                   (backref
                                    (if (flag-set? flags ~case-insensitive?)
                                        'backref-ci
                                        'backref)))
                              (if (not j)
                                  (error "unterminated named backref" str)
                                  (lp (+ j 1) (+ j 1) flags
                                      `((,backref ,(string->symbol s))
                                        ,@(collect))
                                      st))))))
                     ((#\Q)  ;; \Q..\E escapes
                      (let ((res (collect)))
                        (let lp2 ((j (+ i 2)))
                          (cond
                           ((>= j end)
                            (lp j (+ i 2) flags res st))
                           ((eqv? #\\ (string-ref str j))
                            (cond
                             ((>= (+ j 1) end)
                              (lp (+ j 1) (+ i 2) flags res st))
                             ((eqv? #\E (string-ref str (+ j 1)))
                              (lp (+ j 2) (+ j 2) flags
                                  (cons (substring str (+ i 2) j) res) st))
                             (else
                              (lp2 (+ j 2)))))
                           (else
                            (lp2 (+ j 1)))))))
                     ((#\')
                      (with-read-from-string str (+ i 2)
                       (lambda (sre j)
                         (lp j j flags (cons sre (collect)) st))))
                     ;;((#\p)  ; XXXX unicode properties
                     ;; )
                     ;;((#\P)
                     ;; )
                     (else
                      (cond
                       ((char-numeric? c)
                        (let* ((j (or (string-scan-pred
                                       str
                                       (lambda (c) (not (char-numeric? c)))
                                       (+ i 2))
                                      end))
                               (backref
                                (if (flag-set? flags ~case-insensitive?)
                                    'backref-ci
                                    'backref))
                               (res `((,backref ,(string->number
                                                  (substring str (+ i 1) j)))
                                      ,@(collect))))
                          (lp j j flags res st)))
                       ((char-alphabetic? c)
                        (let ((cell (assv c posix-escape-sequences)))
                          (if cell
                              (lp (+ i 2) (+ i 2) flags
                                  (cons (cdr cell) (collect)) st)
                              (error "unknown escape sequence" str c))))
                       (else
                        (lp (+ i 2) (+ i 1) flags (collect) st)))))))))
              ((#\|)
               (lp (+ i 1) (+ i 1) flags (cons 'or (collect)) st))
              ((#\^)
               (let ((sym (if (flag-set? flags ~multi-line?) 'bol 'bos)))
                 (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
              ((#\$)
               (let ((sym (if (flag-set? flags ~multi-line?) 'eol 'eos)))
                 (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
              ((#\space)
               (if (flag-set? flags ~ignore-space?)
                   (lp (+ i 1) (+ i 1) flags (collect) st)
                   (lp (+ i 1) from flags res st)))
              ((#\#)
               (if (flag-set? flags ~ignore-space?)
                   (let ((j (or (string-scan-char str #\newline (+ i 1))
                                (- end 1))))
                     (lp (+ j 1) (+ j 1) flags (collect) st))
                   (lp (+ i 1) from flags res st)))
              (else
               (lp (+ i 1) from flags res st))))))))

(define posix-escape-sequences
  `((#\n . #\newline)
    (#\r . ,(integer->char (+ (char->integer #\newline) 3)))
    (#\t . ,(integer->char (- (char->integer #\newline) 1)))
    (#\a . ,(integer->char (- (char->integer #\newline) 3)))
    (#\e . ,(integer->char (+ (char->integer #\newline) #x11)))
    (#\f . ,(integer->char (+ (char->integer #\newline) 2)))
    ))

(define (char-altcase c)
  (if (char-upper-case? c) (char-downcase c) (char-upcase c)))

(define (char-mirror c)
  (case c ((#\<) #\>) ((#\{) #\}) ((#\() #\)) ((#\[) #\]) (else c)))

(define (string-parse-hex-escape str i end)
  (cond
   ((>= i end)
    (error "incomplete hex escape" str i))
   ((eqv? #\{ (string-ref str i))
    (let ((j (string-scan-char-escape str #\} (+ i 1))))
      (if (not j)
          (error "incomplete hex brace escape" str i)
          (let* ((s (substring str (+ i 1) j))
                 (n (string->number s 16)))
            (if n
                (list (integer->char n) j)
                (error "bad hex brace escape" s))))))
   ((>= (+ i 1) end)
    (error "incomplete hex escape" str i))
   (else
    (let* ((s (substring str i (+ i 2)))
           (n (string->number s 16)))
      (if n
          (list (integer->char n) (+ i 2))
          (error "bad hex escape" s))))))

(define (string-parse-cset str start flags)
  (let* ((end (string-length str))
         (invert? (and (< start end) (eqv? #\^ (string-ref str start))))
         (utf8? (flag-set? flags ~utf8?)))
    (define (go i chars ranges)
      (if (>= i end)
          (error "incomplete char set" str i end)
          (let ((c (string-ref str i)))
            (case c
              ((#\])
               (if (and (null? chars) (null? ranges))
                   (go (+ i 1) (cons #\] chars) ranges)
                   (let ((ci? (flag-set? flags ~case-insensitive?))
                         (hi-chars (if utf8? (filter high-char? chars) '()))
                         (chars (if utf8? (remove high-char? chars) chars)))
                     (list
                      ((lambda (res)
                         (if invert? (cons '~ res) (sre-alternate res)))
                       (append
                        hi-chars
                        (if (pair? chars)
                            (list
                             (list (list->string
                                    ((if ci?
                                         cset-case-insensitive
                                         (lambda (x) x))
                                     (reverse chars)))))
                            '())
                        (if (pair? ranges)
                            (let ((res (if ci?
                                           (cset-case-insensitive
                                            (reverse ranges))
                                           (reverse ranges))))
                              (list (cons '/ (alist->plist res))))
                            '())))
                      i))))
              ((#\-)
               (cond
                ((or (= i start)
                     (and (= i (+ start 1)) (eqv? #\^ (string-ref str start)))
                     (eqv? #\] (string-ref str (+ i 1))))
                 (go (+ i 1) (cons c chars) ranges))
                ((null? chars)
                 (error "bad char-set"))
                (else
                 (let* ((c1 (car chars))
                        (c2 (string-ref str (+ i 1))))
                   (apply
                    (lambda (c2 j)
                      (if (char<? c2 c1)
                          (error "inverted range in char-set" c1 c2)
                          (go j (cdr chars) (cons (cons c1 c2) ranges))))
                    (cond
                     ((and (eqv? #\\ c2) (assv c2 posix-escape-sequences))
                      => (lambda (x) (list (cdr x) (+ i 3))))
                     ((and (eqv? #\\ c2)
                           (eqv? (string-ref str (+ i 2)) #\x))
                      (string-parse-hex-escape str (+ i 3) end))
                     ((and utf8? (<= #x80 (char->integer c2) #xFF))
                      (let ((len (utf8-start-char->length c2)))
                        (list (utf8-string-ref str (+ i 1) len) (+ i 1 len))))
                     (else
                      (list c2 (+ i 2)))))))))
              ((#\[)
               (let* ((inv? (eqv? #\^ (string-ref str (+ i 1))))
                      (i2 (if inv? (+ i 2) (+ i 1))))
                 (case (string-ref str i2)
                   ((#\:)
                    (let ((j (string-scan-char str #\: (+ i2 1))))
                      (if (or (not j) (not (eqv? #\] (string-ref str (+ j 1)))))
                          (error "incomplete character class" str)
                          (let* ((cset (sre->cset
                                        (string->symbol
                                         (substring str (+ i2 1) j))))
                                 (cset (if inv? (cset-complement cset) cset)))
                            (go (+ j 2)
                                (append (filter char? cset) chars)
                                (append (filter pair? cset) ranges))))))
                   ((#\= #\.)
                    (error "collating sequences not supported" str))
                   (else
                    (go (+ i 1) (cons #\[ chars) ranges)))))
              ((#\\)
               (let ((c (string-ref str (+ i 1))))
                 (case c
                   ((#\d #\D #\s #\S #\w #\W)
                    (let ((cset (sre->cset (string->sre (string #\\ c)))))
                      (go (+ i 2)
                          (append (filter char? cset) chars)
                          (append (filter pair? cset) ranges))))
                   ((#\x)
                    (apply
                     (lambda (ch j)
                       (go j (cons ch chars) ranges))
                     (string-parse-hex-escape str (+ i 2) end)))
                   (else
                    (let ((c (cond ((assv c posix-escape-sequences) => cdr)
                                   (else c))))
                      (go (+ i 2)
                          (cons (string-ref str (+ i 1)) (cons c chars))
                          ranges))))))
              (else
               (if (and utf8? (<= #x80 (char->integer c) #xFF))
                   (let ((len (utf8-start-char->length c)))
                     (go (+ i len)
                         (cons (utf8-string-ref str i len) chars)
                         ranges))
                   (go (+ i 1) (cons c chars) ranges)))))))
    (if invert?
        (go (+ start 1)
            (if (flag-set? flags ~multi-line?) '(#\newline) '())
            '())
        (go start '() '()))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; UTF-8 Utilities

;; Here are some hairy optimizations that need to be documented
;; better.  Thanks to these, we never do any utf8 processing once the
;; regexp is compiled.

;; two chars: ab..ef
;;            a[b..xFF]|[b-d][x80..xFF]|e[x80..xFF]

;; three chars: abc..ghi
;;              ab[c..xFF]|a[d..xFF][x80..xFF]|
;;              [b..f][x80..xFF][x80..xFF]|
;;              g[x80..g][x80..xFF]|gh[x80..i]

;; four chars: abcd..ghij
;;             abc[d..xFF]|ab[d..xFF][x80..xFF]|a[c..xFF][x80..xFF][x80..xFF]|
;;             [b..f][x80..xFF][x80..xFF][x80..xFF]|
;;             g[x80..g][x80..xFF][x80..xFF]|gh[x80..h][x80..xFF]|ghi[x80..j]

(define (high-char? c) (<= #x80 (char->integer c)))

;; number of total bytes in a utf8 char given the 1st byte

(define utf8-start-char->length
  (let ((table '#(
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 0x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 1x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 2x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 3x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 4x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 5x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 6x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 7x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 8x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 9x
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; ax
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; bx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; cx
2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; dx
3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 ; ex
4 4 4 4 4 4 4 4 5 5 5 5 6 6 0 0 ; fx
)))
    (lambda (c) (vector-ref table (char->integer c)))))

(define (utf8-string-ref str i len)
  (define (byte n) (char->integer (string-ref str n)))
  (case len
    ((1) ; shouldn't happen in this module
     (string-ref str i))
    ((2)
     (integer->char
      (+ (bit-shl (bit-and (byte i) #b00011111) 6)
         (bit-and (byte (+ i 1)) #b00111111))))
    ((3)
     (integer->char
      (+ (bit-shl (bit-and (byte i) #b00001111) 12)
         (bit-shl (bit-and (byte (+ i 1)) #b00111111) 6)
         (bit-and (byte (+ i 2)) #b00111111))))
    ((4)
     (integer->char
      (+ (bit-shl (bit-and (byte i) #b00000111) 18)
         (bit-shl (bit-and (byte (+ i 1)) #b00111111) 12)
         (bit-shl (bit-and (byte (+ i 2)) #b00111111) 6)
         (bit-and (byte (+ i 3)) #b00111111))))
    (else
     (error "invalid utf8 length" str len i))))

(define (utf8-backup-to-initial-char str i)
  (let lp ((i i))
    (if (= i 0)
        0
        (let ((c (char->integer (string-ref str i))))
          (if (or (< c #x80) (>= c #xC0))
              i
              (lp (- i 1)))))))

(define (utf8-lowest-digit-of-length len)
  (case len
    ((1) 0) ((2) #xC0) ((3) #xE0) ((4) #xF0)
    (else (error "invalid utf8 length" len))))

(define (utf8-highest-digit-of-length len)
  (case len
    ((1) #x7F) ((2) #xDF) ((3) #xEF) ((4) #xF7)
    (else (error "invalid utf8 length" len))))

(define (char->utf8-list c)
  (let ((i (char->integer c)))
    (cond
     ((<= i #x7F) (list i))
     ((<= i #x7FF)
      (list (bit-ior #b11000000 (bit-shr i 6))
            (bit-ior #b10000000 (bit-and i #b111111))))
     ((<= i #xFFFF)
      (list (bit-ior #b11100000 (bit-shr i 12))
            (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
            (bit-ior #b10000000 (bit-and i #b111111))))
     ((<= i #x1FFFFF)
      (list (bit-ior #b11110000 (bit-shr i 18))
            (bit-ior #b10000000 (bit-and (bit-shr i 12) #b111111))
            (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
            (bit-ior #b10000000 (bit-and i #b111111))))
     (else (error "unicode codepoint out of range:" i)))))

(define (unicode-range->utf8-pattern lo hi)
  (let ((lo-ls (char->utf8-list lo))
        (hi-ls (char->utf8-list hi)))
    (if (not (= (length lo-ls) (length hi-ls)))
        (sre-alternate (list (unicode-range-climb-digits lo-ls hi-ls)
                             (unicode-range-up-to hi-ls)))
        (let lp ((lo-ls lo-ls) (hi-ls hi-ls))
          (cond
           ((null? lo-ls)
            '())
           ((= (car lo-ls) (car hi-ls))
            (sre-sequence
             (list (integer->char (car lo-ls))
                   (lp (cdr lo-ls) (cdr hi-ls)))))
           ((= (+ (car lo-ls) 1) (car hi-ls))
            (sre-alternate (list (unicode-range-up-from lo-ls)
                                 (unicode-range-up-to hi-ls))))
           (else
            (sre-alternate (list (unicode-range-up-from lo-ls)
                                 (unicode-range-middle lo-ls hi-ls)
                                 (unicode-range-up-to hi-ls)))))))))

(define (unicode-range-helper one ls prefix res)
  (if (null? ls)
      res
      (unicode-range-helper
       one
       (cdr ls)
       (cons (car ls) prefix)
       (cons (sre-sequence
              `(,@(map integer->char prefix)
                ,(one (car ls))
                ,@(map (lambda (_)
                         `(/ ,(integer->char #x80)
                             ,(integer->char #xFF)))
                       (cdr ls))))
             res))))

(define (unicode-range-up-from lo-ls)
  (sre-sequence
   (list (integer->char (car lo-ls))
         (sre-alternate
          (unicode-range-helper
           (lambda (c)
             `(/ ,(integer->char (+ (car lo-ls) 1)) ,(integer->char #xFF)))
           (cdr (reverse (cdr lo-ls)))
           '()
           (list
            (sre-sequence
             (append
              (map integer->char (reverse (cdr (reverse (cdr lo-ls)))))
              `((/ ,(integer->char (last lo-ls))
                   ,(integer->char #xFF)))))))))))

(define (unicode-range-up-to hi-ls)
  (sre-sequence
   (list (integer->char (car hi-ls))
         (sre-alternate
          (unicode-range-helper
           (lambda (c)
             `(/ ,(integer->char #x80) ,(integer->char (- (car hi-ls) 1))))
           (cdr (reverse (cdr hi-ls)))
           '()
           (list
            (sre-sequence
             (append
              (map integer->char (reverse (cdr (reverse (cdr hi-ls)))))
              `((/ ,(integer->char #x80)
                   ,(integer->char (last hi-ls))))))))))))

(define (unicode-range-climb-digits lo-ls hi-ls)
  (let ((lo-len (length lo-ls)))
    (sre-alternate
     (append
      (list
       (sre-sequence
        (cons `(/ ,(integer->char (car lo-ls))
                  ,(integer->char (if (<= (car lo-ls) #x7F) #x7F #xFF)))
              (map (lambda (_)
                     `(/ ,(integer->char #x80) ,(integer->char #xFF)))
                   (cdr lo-ls)))))
      (map
       (lambda (i)
         (sre-sequence
          (cons
           `(/ ,(integer->char (utf8-lowest-digit-of-length (+ i lo-len 1)))
               ,(integer->char (utf8-highest-digit-of-length (+ i lo-len 1))))
           (map (lambda (_)
                  `(/ ,(integer->char #x80) ,(integer->char #xFF)))
                (zero-to (+ i lo-len))))))
       (zero-to (- (length hi-ls) lo-len 1)))
      (list
       (sre-sequence
        (cons `(/ ,(integer->char
                    (utf8-lowest-digit-of-length
                     (utf8-start-char->length
                      (integer->char (- (car hi-ls) 1)))))
                  ,(integer->char (- (car hi-ls) 1)))
              (map (lambda (_)
                     `(/ ,(integer->char #x80) ,(integer->char #xFF)))
                   (cdr hi-ls)))))))))

(define (unicode-range-middle lo-ls hi-ls)
  (let ((lo (integer->char (+ (car lo-ls) 1)))
        (hi (integer->char (- (car hi-ls) 1))))
    (sre-sequence
     (cons (if (char=? lo hi) lo `(/ ,lo ,hi))
           (map (lambda (_) `(/ ,(integer->char #x80) ,(integer->char #xFF)))
                (cdr lo-ls))))))

(define (cset->utf8-pattern cset)
  (let lp ((ls cset) (alts '()) (lo-cset '()))
    (cond
     ((null? ls)
      (sre-alternate (append (reverse alts)
                             (if (null? lo-cset)
                                 '()
                                 (list (cons '/ (reverse lo-cset)))))))
     ((char? (car ls))
      (if (high-char? (car ls))
          (lp (cdr ls) (cons (car ls) alts) lo-cset)
          (lp (cdr ls) alts (cons (car ls) lo-cset))))
     (else
      (if (or (high-char? (caar ls))  (high-char? (cdar ls)))
          (lp (cdr ls)
              (cons (unicode-range->utf8-pattern (caar ls) (cdar ls)) alts)
              lo-cset)
          (lp (cdr ls) alts (cons (cdar ls) (cons (caar ls) lo-cset))))))))

(define (sre-adjust-utf8 sre flags)
  (let adjust ((sre sre)
               (utf8? (flag-set? flags ~utf8?))
               (ci? (flag-set? flags ~case-insensitive?)))
    (define (rec sre) (adjust sre utf8? ci?))
    (cond
     ((pair? sre)
      (case (car sre)
        ((w/utf8) (adjust (sre-sequence (cdr sre)) #t ci?))
        ((w/noutf8) (adjust (sre-sequence (cdr sre)) #f ci?))
        ((w/case)
         (cons (car sre) (map (lambda (s) (adjust s utf8? #f)) (cdr sre))))
        ((w/nocase)
         (cons (car sre) (map (lambda (s) (adjust s utf8? #t)) (cdr sre))))
        ((/ ~ & -)
         (if (not utf8?)
             sre
             (let ((cset (sre->cset sre ci?)))
               (if (any (lambda (x)
                          (if (pair? x)
                              (or (high-char? (car x)) (high-char? (cdr x)))
                              (high-char? x)))
                        cset)
                   (if ci?
                       (list 'w/case (cset->utf8-pattern cset))
                       (cset->utf8-pattern cset))
                   sre))))
        ((*)
         (case (sre-sequence (cdr sre))
           ;; special case optimization: .* w/utf8 == .* w/noutf8
           ((any) '(* any))
           ((nonl) '(* nonl))
           (else (cons '* (map rec (cdr sre))))))
        (else
         (cons (car sre) (map rec (cdr sre))))))
     (else
      (case sre
        ((any) 'utf8-any)
        ((nonl) 'utf8-nonl)
        (else
         (if (and utf8? (char? sre) (high-char? sre))
             (sre-sequence (map integer->char (char->utf8-list sre)))
             sre)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Compilation

(define (irregex x . o)
  (cond
   ((irregex? x) x)
   ((string? x) (apply string->irregex x o))
   (else (apply sre->irregex x o))))

(define (string->irregex str . o)
  (apply sre->irregex (apply string->sre str o) o))

(define (sre->irregex sre . o)
  (let* ((pat-flags (symbol-list->flags o))
         (sre (if *allow-utf8-mode?*
                  (sre-adjust-utf8 sre pat-flags)
                  sre))
         (searcher? (sre-searcher? sre))
         (sre-dfa (if searcher? (sre-remove-initial-bos sre) sre))
         (dfa-limit (cond ((memq 'small o) 1) ((memq 'fast o) 50) (else 10)))
         (dfa/search
          (cond ((memq 'backtrack o) #f)
                (searcher? #t)
                ((sre->nfa `(seq (* any) ,sre-dfa) pat-flags)
                 => (lambda (nfa)
                      (nfa->dfa nfa (* dfa-limit (nfa-num-states nfa)))))
                (else #f)))
         (dfa (cond ((and dfa/search (sre->nfa sre-dfa pat-flags))
                     => (lambda (nfa)
                          (nfa->dfa nfa (* dfa-limit (nfa-num-states nfa)))))
                    (else #f)))
         (submatches (sre-count-submatches sre-dfa))
         (extractor
          (and dfa dfa/search (sre-match-extractor sre-dfa submatches)))
         (names (sre-names sre-dfa 1 '()))
         (lens (sre-length-ranges sre-dfa names))
         (flags (flag-join
                 (flag-join ~none (and searcher? ~searcher?))
                 (and (sre-consumer? sre) ~consumer?))))
    (cond
     (dfa
      (make-irregex dfa dfa/search extractor #f flags submatches lens names))
     (else
      (let ((f (sre->procedure sre pat-flags names)))
        (make-irregex #f #f #f f flags submatches lens names))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SRE Analysis

;; returns #t if the sre can ever be empty
(define (sre-empty? sre)
  (if (pair? sre)
      (case (car sre)
        ((* ? look-ahead look-behind neg-look-ahead neg-look-behind) #t)
        ((**) (or (not (number? (cadr sre))) (zero? (cadr sre))))
        ((or) (any sre-empty? (cdr sre)))
        ((: seq $ submatch => submatch-named + atomic)
         (every sre-empty? (cdr sre)))
        (else #f))
      (memq sre '(epsilon bos eos bol eol bow eow commit))))

(define (sre-any? sre)
  (or (eq? sre 'any)
      (and (pair? sre)
           (case (car sre)
             ((seq : $ submatch => submatch-named)
              (and (pair? (cdr sre)) (null? (cddr sre)) (sre-any? (cadr sre))))
             ((or) (every sre-any? (cdr sre)))
             (else #f)))))

(define (sre-repeater? sre)
  (and (pair? sre)
       (or (memq (car sre) '(* +))
           (and (memq (car sre) '($ submatch => submatch-named seq :))
                (pair? (cdr sre))
                (null? (cddr sre))
                (sre-repeater? (cadr sre))))))

(define (sre-searcher? sre)
  (if (pair? sre)
      (case (car sre)
        ((* +) (sre-any? (sre-sequence (cdr sre))))
        ((seq : $ submatch => submatch-named)
         (and (pair? (cdr sre)) (sre-searcher? (cadr sre))))
        ((or) (every sre-searcher? (cdr sre)))
        (else #f))
      (eq? 'bos sre)))

(define (sre-consumer? sre)
  (if (pair? sre)
      (case (car sre)
        ((* +) (sre-any? (sre-sequence (cdr sre))))
        ((seq : $ submatch => submatch-named)
         (and (pair? (cdr sre)) (sre-consumer? (last sre))))
        ((or) (every sre-consumer? (cdr sre)))
        (else #f))
      (eq? 'eos sre)))

(define (sre-has-submatches? sre)
  (and (pair? sre)
       (or (memq (car sre) '($ submatch => submatch-named))
           (if (eq? 'posix-string (car sre))
               (sre-has-submatches? (string->sre (cadr sre)))
               (any sre-has-submatches? (cdr sre))))))

(define (sre-count-submatches sre)
  (let count ((sre sre) (sum 0))
    (if (pair? sre)
        (fold count
              (+ sum (case (car sre)
                       (($ submatch => submatch-named) 1)
                       ((dsm) (+ (cadr sre) (caddr sre)))
                       ((posix-string)
                        (sre-count-submatches (string->sre (cadr sre))))
                       (else 0)))
              (cdr sre))
        sum)))

(define (sre-length-ranges sre . o)
  (let ((names (if (pair? o) (car o) (sre-names sre 1 '())))
        (sublens (make-vector (+ 1 (sre-count-submatches sre)) #f)))
    (vector-set!
     sublens
     0
     (let lp ((sre sre) (n 1) (lo 0) (hi 0) (return cons))
       (define (grow i) (return (+ lo i) (and hi (+ hi i))))
       (cond
        ((pair? sre)
         (if (string? (car sre))
             (grow 1)
             (case (car sre)
               ((/ ~ & -)
                (grow 1))
               ((posix-string)
                (lp (string->sre (cadr sre)) n lo hi return))
               ((seq : w/case w/nocase atomic)
                (let lp2 ((ls (cdr sre)) (n n) (lo2 0) (hi2 0))
                  (if (null? ls)
                      (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
                      (lp (car ls) n 0 0
                          (lambda (lo3 hi3)
                            (lp2 (cdr ls)
                                 (+ n (sre-count-submatches (car ls)))
                                 (+ lo2 lo3)
                                 (and hi2 hi3 (+ hi2 hi3))))))))
               ((or)
                (let lp2 ((ls (cdr sre)) (n n) (lo2 #f) (hi2 0))
                  (if (null? ls)
                      (return (+ lo (or lo2 1)) (and hi hi2 (+ hi hi2)))
                      (lp (car ls) n 0 0
                          (lambda (lo3 hi3)
                            (lp2 (cdr ls)
                                 (+ n (sre-count-submatches (car ls)))
                                 (if lo2 (min lo2 lo3) lo3)
                                 (and hi2 hi3 (max hi2 hi3))))))))
               ((if)
                (cond
                 ((or (null? (cdr sre)) (null? (cddr sre)))
                  (return lo hi))
                 (else
                  (let ((n1 (sre-count-submatches (car sre)))
                        (n2 (sre-count-submatches (cadr sre))))
                    (lp (if (or (number? (cadr sre)) (symbol? (cadr sre)))
                            'epsilon
                            (cadr sre))
                        n lo hi
                        (lambda (lo2 hi2)
                          (lp (caddr sre) (+ n n1) 0 0
                              (lambda (lo3 hi3)
                                (lp (if (pair? (cdddr sre))
                                        (cadddr sre)
                                        'epsilon)
                                    (+ n n1 n2) 0 0
                                    (lambda (lo4 hi4)
                                      (return (+ lo2 (min lo3 lo4))
                                              (and hi2 hi3 hi4
                                                   (+ hi2 (max hi3 hi4))
                                                   ))))))))))))
               ((dsm)
                (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) lo hi return))
               (($ submatch => submatch-named)
                (lp (sre-sequence
                     (if (eq? 'submatch (car sre)) (cdr sre) (cddr sre)))
                    (+ n 1) lo hi
                    (lambda (lo2 hi2)
                      (vector-set! sublens n (cons lo2 hi2))
                      (return lo2 hi2))))
               ((backref backref-ci)
                (let ((n (cond
                          ((number? (cadr sre)) (cadr sre))
                          ((assq (cadr sre) names) => cdr)
                          (else (error "unknown backreference" (cadr sre))))))
                  (cond
                   ((or (not (integer? n))
                        (not (< 0 n (vector-length sublens))))
                    (error "sre-length: invalid backreference" sre))
                   ((not (vector-ref sublens n))
                    (error "sre-length: invalid forward backreference" sre))
                   (else
                    (let ((lo2 (car (vector-ref sublens n)))
                          (hi2 (cdr (vector-ref sublens n))))
                      (return (+ lo lo2) (and hi hi2 (+ hi hi2))))))))
               ((* *?)
                (lp (sre-sequence (cdr sre)) n lo hi (lambda (lo hi) #f))
                (return lo #f))
               ((** **?)
                (cond
                 ((or (and (number? (cadr sre))
                           (number? (caddr sre))
                           (> (cadr sre) (caddr sre)))
                      (and (not (cadr sre)) (caddr sre)))
                  (return lo hi))
                 (else
                  (if (caddr sre)
                      (lp (sre-sequence (cdddr sre)) n 0 0
                          (lambda (lo2 hi2)
                            (return (+ lo (* (cadr sre) lo2))
                                    (and hi hi2 (+ hi (* (caddr sre) hi2))))))
                      (lp (sre-sequence (cdddr sre)) n 0 0
                          (lambda (lo2 hi2)
                            (return (+ lo (* (cadr sre) lo2)) #f)))))))
               ((+)
                (lp (sre-sequence (cdr sre)) n lo hi
                    (lambda (lo2 hi2)
                      (return (+ lo lo2) #f))))
               ((? ??)
                (lp (sre-sequence (cdr sre)) n lo hi
                    (lambda (lo2 hi2)
                      (return lo (and hi hi2 (+ hi hi2))))))
               ((= =? >= >=?)
                (lp `(** ,(cadr sre)
                         ,(if (memq (car sre) '(>= >=?)) #f (cadr sre))
                         ,@(cddr sre))
                    n lo hi return))
               ((look-ahead neg-look-ahead look-behind neg-look-behind)
                (return lo hi))
               (else
                (cond
                 ((assq (car sre) sre-named-definitions)
                  => (lambda (cell)
                       (lp (apply (cdr cell) (cdr sre)) n lo hi return)))
                 (else
                  (error "sre-length-ranges: unknown sre operator" sre)))))))
        ((char? sre)
         (grow 1))
        ((string? sre)
         (grow (string-length sre)))
        ((memq sre '(any nonl))
         (grow 1))
        ((memq sre '(epsilon bos eos bol eol bow eow nwb commit))
         (return lo hi))
        (else
         (let ((cell (assq sre sre-named-definitions)))
           (if cell
               (lp (if (procedure? (cdr cell)) ((cdr cell)) (cdr cell))
                   n lo hi return)
               (error "sre-length-ranges: unknown sre" sre)))))))
    sublens))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SRE Manipulation

;; build a (seq ls ...) sre from a list
(define (sre-sequence ls)
  (cond
   ((null? ls) 'epsilon)
   ((null? (cdr ls)) (car ls))
   (else (cons 'seq ls))))

;; build a (or ls ...) sre from a list
(define (sre-alternate ls)
  (cond
   ((null? ls) '(or))
   ((null? (cdr ls)) (car ls))
   (else (cons 'or ls))))

;; returns an equivalent SRE without any match information
(define (sre-strip-submatches sre)
  (if (not (pair? sre))
      sre
      (case (car sre)
        (($ submatch) (sre-strip-submatches (sre-sequence (cdr sre))))
        ((=> submatch-named) (sre-strip-submatches (sre-sequence (cddr sre))))
        ((dsm) (sre-strip-submatches (sre-sequence (cdddr sre))))
        (else (map sre-strip-submatches sre)))))

;; given a char-set list of chars and strings, flattens them into
;; chars only
(define (sre-flatten-ranges ls)
  (let lp ((ls ls) (res '()))
    (cond
     ((null? ls)
      (reverse res))
     ((string? (car ls))
      (lp (append (string->list (car ls)) (cdr ls)) res))
     (else
      (lp (cdr ls) (cons (car ls) res))))))

(define (sre-names sre n names)
  (if (not (pair? sre))
      names
      (case (car sre)
        (($ submatch)
         (sre-names (sre-sequence (cdr sre)) (+ n 1) names))
        ((=> submatch-named)
         (sre-names (sre-sequence (cddr sre))
                    (+ n 1)
                    (cons (cons (cadr sre) n) names)))
        ((dsm)
         (sre-names (sre-sequence (cdddr sre)) (+ n (cadr sre)) names))
        ((seq : or * + ? *? ?? w/case w/nocase atomic
          look-ahead look-behind neg-look-ahead neg-look-behind)
         (sre-sequence-names (cdr sre) n names))
        ((= >=)
         (sre-sequence-names (cddr sre) n names))
        ((** **?)
         (sre-sequence-names (cdddr sre) n names))
        (else
         names))))

(define (sre-sequence-names ls n names)
  (if (null? ls)
      names
      (sre-sequence-names (cdr ls)
                          (+ n (sre-count-submatches (car ls)))
                          (sre-names (car ls) n names))))

(define (sre-remove-initial-bos sre)
  (cond
   ((pair? sre)
    (case (car sre)
      ((seq : $ submatch => submatch-named * +)
       (cond
        ((not (pair? (cdr sre)))
         sre)
        ((eq? 'bos (cadr sre))
         (cons (car sre) (cddr sre)))
        (else
         (cons (car sre)
               (cons (sre-remove-initial-bos (cadr sre)) (cddr sre))))))
      ((or)
       (sre-alternate (map sre-remove-initial-bos (cdr sre))))
      (else
       sre)))
   (else
    sre)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Basic Matching

(define irregex-basic-string-chunker
  (make-irregex-chunker (lambda (x) #f)
                        car
                        cadr
                        caddr
                        (lambda (src1 i src2 j)
                          (substring (car src1) i j))))

(define (irregex-search x str . o)
  (if (not (string? str)) (error "irregex-search: not a string" str))
  (let ((start (or (and (pair? o) (car o)) 0))
        (end (or (and (pair? o) (pair? (cdr o)) (cadr o)) (string-length str))))
    (irregex-search/chunked x
                            irregex-basic-string-chunker
                            (list str start end)
                            start)))

(define (irregex-search/chunked x cnk src . o)
  (let* ((irx (irregex x))
         (matches (irregex-new-matches irx))
         (i (if (pair? o) (car o) ((chunker-get-start cnk) src))))
    (irregex-match-chunker-set! matches cnk)
    (irregex-search/matches irx cnk src i matches)))

;; internal routine, can be used in loops to avoid reallocating the
;; match vector
(define (irregex-search/matches irx cnk src i matches)
  (cond
   ((irregex-dfa irx)
    (cond
     ((flag-set? (irregex-flags irx) ~searcher?)
      (cond
       ((dfa-match/longest (irregex-dfa irx) cnk src i #f #f matches 0)
        (irregex-match-start-chunk-set! matches 0 src)
        (irregex-match-start-index-set! matches 0 i)
        ((irregex-dfa/extract irx)
         cnk src i
         (%irregex-match-end-chunk matches 0)
         (%irregex-match-end-index matches 0)
         matches)
        matches)
       (else
        #f)))
     ((dfa-match/shortest
       (irregex-dfa/search irx) cnk src i matches 0)
      (let ((dfa (irregex-dfa irx))
            (get-start (chunker-get-start cnk))
            (get-end (chunker-get-end cnk))
            (get-next (chunker-get-next cnk)))
        (let lp1 ((src src) (i i))
          (let ((end (get-end src)))
            (let lp2 ((i i))
              (cond
               ((dfa-match/longest dfa cnk src i #f #f matches 0)
                (irregex-match-start-chunk-set! matches 0 src)
                (irregex-match-start-index-set! matches 0 i)
                ((irregex-dfa/extract irx)
                 cnk src i
                 (%irregex-match-end-chunk matches 0)
                 (%irregex-match-end-index matches 0)
                 matches)
                matches)
               ((>= i end)
                (let ((next (get-next src)))
                  (and next (lp1 next (get-start next)))))
               (else
                (lp2 (+ i 1)))))))))
     (else
      #f)))
   (else
    (let ((res (irregex-search/backtrack irx cnk src i matches)))
      (if res (%irregex-match-fail-set! res #f))
      res))))

(define (irregex-search/backtrack irx cnk src i matches)
  (let ((matcher (irregex-nfa irx))
        (str ((chunker-get-str cnk) src))
        (end ((chunker-get-end cnk) src))
        (get-next (chunker-get-next cnk))
        (init (cons src i)))
    (if (flag-set? (irregex-flags irx) ~searcher?)
        (matcher cnk init src str i end matches (lambda () #f))
        (let lp ((src2 src)
                 (str str)
                 (i i)
                 (end end))
          (cond
           ((matcher cnk init src2 str i end matches (lambda () #f))
            (irregex-match-start-chunk-set! matches 0 src2)
            (irregex-match-start-index-set! matches 0 i)
            matches)
           ((< i end)
            (lp src2 str (+ i 1) end))
           (else
            (let ((src2 (get-next src2)))
              (if src2
                  (lp src2
                      ((chunker-get-str cnk) src2)
                      ((chunker-get-start cnk) src2)
                      ((chunker-get-end cnk) src2))
                  #f))))))))

(define (irregex-match irx str . o)
  (if (not (string? str)) (error "irregex-match: not a string" str))
  (let ((start (or (and (pair? o) (car o)) 0))
        (end (or (and (pair? o) (pair? (cdr o)) (cadr o)) (string-length str))))
    (irregex-match/chunked irx
                           irregex-basic-string-chunker
                           (list str start end))))

(define (irregex-match/chunked irx cnk src)
  (let* ((irx (irregex irx))
         (matches (irregex-new-matches irx)))
    (irregex-match-chunker-set! matches cnk)
    (cond
     ((irregex-dfa irx)
      (and
       (dfa-match/longest
        (irregex-dfa irx) cnk src ((chunker-get-start cnk) src) #f #f matches 0)
       (= ((chunker-get-end cnk) (%irregex-match-end-chunk matches 0))
          (%irregex-match-end-index matches 0))
       (begin
         (irregex-match-start-chunk-set! matches 0 src)
         (irregex-match-start-index-set! matches
                                         0
                                         ((chunker-get-start cnk) src))
         ((irregex-dfa/extract irx)
          cnk src ((chunker-get-start cnk) src)
          (%irregex-match-end-chunk matches 0)
          (%irregex-match-end-index matches 0)
          matches)
         matches)))
     (else
      (let* ((matcher (irregex-nfa irx))
             (str ((chunker-get-str cnk) src))
             (i ((chunker-get-start cnk) src))
             (end ((chunker-get-end cnk) src))
             (init (cons src i)))
        (let lp ((m (matcher cnk init src str i end matches (lambda () #f))))
          (and m
               (cond
                ((and (not ((chunker-get-next cnk)
                            (%irregex-match-end-chunk m 0)))
                      (= ((chunker-get-end cnk)
                          (%irregex-match-end-chunk m 0))
                         (%irregex-match-end-index m 0)))
                 (%irregex-match-fail-set! m #f)
                 m)
                ((%irregex-match-fail m)
                 (lp ((%irregex-match-fail m))))
                (else
                 #f)))))))))

(define (irregex-match? . args)
  (and (apply irregex-match args) #t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; DFA Matching

;; inline these
(define (dfa-init-state dfa)
  (vector-ref dfa 0))
(define (dfa-next-state dfa node)
  (vector-ref dfa (cdr node)))
(define (dfa-final-state? dfa state)
  (car state))

;; this searches for the first end index for which a match is possible
(define (dfa-match/shortest dfa cnk src start matches index)
  (let ((get-str (chunker-get-str cnk))
        (get-start (chunker-get-start cnk))
        (get-end (chunker-get-end cnk))
        (get-next (chunker-get-next cnk)))
    (let lp1 ((src src) (start start) (state (dfa-init-state dfa)))
      (and
       src
       (let ((str (get-str src))
             (end (get-end src)))
         (let lp2 ((i start) (state state))
           (cond
            ((dfa-final-state? dfa state)
             (cond
              (index
               (irregex-match-end-chunk-set! matches index src)
               (irregex-match-end-index-set! matches index i)))
             #t)
            ((< i end)
             (let* ((ch (string-ref str i))
                    (next (find (lambda (x)
                                  (if (eqv? ch (car x))
                                      #t
                                      (and (pair? (car x))
                                           (char<=? (caar x) ch)
                                           (char<=? ch (cdar x)))))
                                (cdr state))))
               (and next (lp2 (+ i 1) (dfa-next-state dfa next)))))
            (else
             (let ((next (get-next src)))
               (and next (lp1 next (get-start next) state)))))))))))

;; this finds the longest match starting at a given index
(define (dfa-match/longest dfa cnk src start end-src end matches index)
  (let ((get-str (chunker-get-str cnk))
        (get-start (chunker-get-start cnk))
        (get-end (chunker-get-end cnk))
        (get-next (chunker-get-next cnk))
        (start-is-final? (dfa-final-state? dfa (dfa-init-state dfa))))
    (cond
     (index
      (irregex-match-end-chunk-set! matches index #f)
      (irregex-match-end-index-set! matches index #f)))
    (let lp1 ((src src)
              (start start)
              (state (dfa-init-state dfa))
              (res-src (and start-is-final? src))
              (res-index (and start-is-final? start)))
      (let ((str (get-str src))
            (end (if (eq? src end-src) end (get-end src))))
        (let lp2 ((i start)
                  (state state)
                  (res-src res-src)
                  (res-index res-index))
          (cond
           ((>= i end)
            (cond
             ((and index res-src)
              (irregex-match-end-chunk-set! matches index res-src)
              (irregex-match-end-index-set! matches index res-index)))
            (let ((next (and (not (eq? src end-src)) (get-next src))))
              (if next
                  (lp1 next (get-start next) state res-src res-index)
                  (and index
                       (%irregex-match-end-chunk matches index)
                       #t))))
           (else
            (let* ((ch (string-ref str i))
                   (cell (find (lambda (x)
                                 (if (eqv? ch (car x))
                                     #t
                                     (and (pair? (car x))
                                          (char<=? (caar x) ch)
                                          (char<=? ch (cdar x)))))
                               (cdr state))))
              (cond
               (cell
                (let ((next (dfa-next-state dfa cell)))
                  (if (dfa-final-state? dfa next)
                      (lp2 (+ i 1) next src (+ i 1))
                      (lp2 (+ i 1) next res-src res-index))))
               (res-src
                (cond
                 (index
                  (irregex-match-end-chunk-set! matches index res-src)
                  (irregex-match-end-index-set! matches index res-index)))
                #t)
               ((and index (%irregex-match-end-chunk matches index))
                #t)
               (else
                #f))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Named Definitions

(define sre-named-definitions
  `((any . ,*all-chars*)
    (nonl . (- ,*all-chars* (,(string #\newline))))
    (alphabetic . (/ #\a #\z #\A #\Z))
    (alpha . alphabetic)
    (alphanumeric . (/ #\a #\z #\A #\Z #\0 #\9))
    (alphanum . alphanumeric)
    (alnum . alphanumeric)
    (lower-case . (/ #\a #\z))
    (lower . lower-case)
    (upper-case . (/ #\A #\Z))
    (upper . upper-case)
    (numeric . (/ #\0 #\9))
    (num . numeric)
    (digit . numeric)
    (punctuation . (or #\! #\" #\# #\% #\& #\' #\( #\) #\* #\, #\- #\.
                       #\/ #\: #\; #\? #\@ #\[ #\\ #\] #\_ #\{ #\}))
    (punct . punctuation)
    (graphic
     . (or alphanumeric punctuation #\$ #\+ #\< #\= #\> #\^ #\` #\| #\~))
    (graph . graphic)
    (blank . (or #\space ,(integer->char (- (char->integer #\space) 23))))
    (whitespace . (or blank #\newline))
    (space . whitespace)
    (white . whitespace)
    (printing or graphic whitespace)
    (print . printing)

    ;; XXXX we assume a (possibly shifted) ASCII-based ordering
    (control . (/ ,(integer->char (- (char->integer #\space) 32))
                  ,(integer->char (- (char->integer #\space) 1))))
    (cntrl . control)
    (hex-digit . (or numeric (/ #\a #\f #\A #\F)))
    (xdigit . hex-digit)
    (ascii . (/ ,(integer->char (- (char->integer #\space) 32))
                ,(integer->char (+ (char->integer #\space) 95))))
    (ascii-nonl . (/ ,(integer->char (- (char->integer #\space) 32))
                     ,(integer->char (- (char->integer #\newline) 1))
                     ,(integer->char (+ (char->integer #\newline) 1))
                     ,(integer->char (+ (char->integer #\space) 95))))
    (newline . (or (seq ,(integer->char (+ (char->integer #\newline) 3))
                        #\newline)
                   (/ #\newline
                      ,(integer->char (+ (char->integer #\newline) 3)))))

    ;; ... it's really annoying to support old Scheme48
    (word . (seq bow (+ (or alphanumeric #\_)) eow))
    (utf8-tail-char . (/ ,(integer->char (+ (char->integer #\space) #x60))
                         ,(integer->char (+ (char->integer #\space) #xA1))))
    (utf8-2-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xA2))
                           ,(integer->char (+ (char->integer #\space) #xBF)))
                        utf8-tail-char))
    (utf8-3-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xC0))
                           ,(integer->char (+ (char->integer #\space) #xCF)))
                        utf8-tail-char
                        utf8-tail-char))
    (utf8-4-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xD0))
                           ,(integer->char (+ (char->integer #\space) #xD7)))
                        utf8-tail-char
                        utf8-tail-char
                        utf8-tail-char))
    (utf8-any . (or ascii utf8-2-char utf8-3-char utf8-4-char))
    (utf8-nonl . (or ascii-nonl utf8-2-char utf8-3-char utf8-4-char))

    ;; extended library patterns
    (integer . (seq (? (or #\+ #\-)) (+ numeric)))
    (real . (seq (+ numeric) (? #\. (+ numeric)) (? (or #\e #\E) integer)))
    ;; slightly more lax than R5RS, allow ->foo, etc.
    (symbol-initial . (or alpha ("!$%&*/:<=>?^_~")))
    (symbol-subsequent . (or symbol-initial digit ("+-.@")))
    (symbol . (or (seq symbol-initial (* symbol-subsequent))
                  (seq ("+-") (? symbol-initial (* symbol-subsequent)))
                  (seq ".." (* "."))))
    (sexp-space . (seq (* (* space) ";" (* nonl) newline) (+ space)))
    (string . (seq #\" (escape #\\ #\") #\"))
    (escape . ,(lambda (esc . o) `(* (or (~ ,esc ,@o) (seq ,esc any)))))

    (ipv4-digit . (seq (? (/ "12")) (? numeric) numeric))
    (ipv4-address . (seq ipv4-digit (= 3 #\. ipv4-digit)))
    ;; XXXX lax, allows multiple double-colons or < 8 terms w/o a ::
    (ipv6-address . (seq (** 0 4 hex-digit)
                         (** 1 7 #\: (? #\:) (** 0 4 hex-digit))))
    (ip-address . (or ipv4-address ipv6-address))
    (domain-atom . (+ (or alphanumeric #\_ #\-)))
    (domain . (seq domain-atom (+ #\. domain-atom)))
    ;; XXXX now anything can be a top-level domain, but this is still handy
    (top-level-domain . (w/nocase (or "arpa" "com" "gov" "mil" "net" "org"
                                      "aero" "biz" "coop" "info" "museum"
                                      "name" "pro" (= 2 alpha))))
    (domain/common . (seq (+ domain-atom #\.) top-level-domain))
    ;;(email-local-part . (seq (+ (or (~ #\") string))))
    (email-local-part . (+ (or alphanumeric #\_ #\- #\. #\+)))
    (email . (seq email-local-part #\@ domain))
    (url-char . (or alnum #\_ #\- #\+ #\\ #\= #\~ #\. #\, #\& #\;
                    (seq "%" hex-digit hex-digit)))
    (url-final-char . (or alnum #\_ #\- #\+ #\\ #\= #\~ #\&
                          (seq "%" hex-digit hex-digit)))
    (http-url . (w/nocase
                 "http" (? "s") "://"
                 (or domain/common ipv4-address) ;; (seq "[" ipv6-address "]")
                 (? ":" (+ numeric)) ;; port
                 ;; path
                 (? "/" (* url-char)
                    (? "?" (* url-char))                      ;; query
                    (? "#" (? (* url-char) url-final-char)) ;; fragment
                    )))

    ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; SRE->NFA compilation
;;
;; An NFA state is a numbered node with a list of patter->number
;; transitions, where pattern is either a character, (lo . hi)
;; character range, or epsilon (indicating an empty transition).
;; There may be duplicate characters and overlapping ranges - since
;; it's an NFA we process it by considering all possible transitions.

(define *nfa-presize* 128)  ;; constant
(define *nfa-num-fields* 4) ;; constant

(define (nfa-num-states nfa) (quotient (vector-length nfa) *nfa-num-fields*))
(define (nfa-start-state nfa) (- (nfa-num-states nfa) 1))

(define (nfa-get-state-trans nfa i)
  (vector-ref nfa (* i *nfa-num-fields*)))
(define (nfa-set-state-trans! nfa i x)
  (vector-set! nfa (* i *nfa-num-fields*) x))
(define (nfa-push-state-trans! nfa i x)
  (nfa-set-state-trans! nfa i (cons x (nfa-get-state-trans nfa i))))

(define (nfa-get-epsilons nfa i)
  (vector-ref nfa (+ (* i *nfa-num-fields*) 1)))
(define (nfa-set-epsilons! nfa i x)
  (vector-set! nfa (+ (* i *nfa-num-fields*) 1) x))
(define (nfa-add-epsilon! nfa i x)
  (let ((eps (nfa-get-epsilons nfa i)))
    (if (not (memq x eps))
        (nfa-set-epsilons! nfa i (cons x eps)))))

(define (nfa-get-state-closure nfa i)
  (vector-ref nfa (+ (* i *nfa-num-fields*) 2)))
(define (nfa-set-state-closure! nfa i x)
  (vector-set! nfa (+ (* i *nfa-num-fields*) 2) x))

(define (nfa-get-closure nfa mst)
  (cond ((assoc mst
                (vector-ref nfa (+ (* (nfa-multi-state-hash nfa mst)
                                      *nfa-num-fields*)
                                   (- *nfa-num-fields* 1))))
         => cdr)
        (else #f)))
(define (nfa-add-closure! nfa mst x)
  (let ((i (+ (* (nfa-multi-state-hash nfa mst) *nfa-num-fields*)
              (- *nfa-num-fields* 1))))
    (vector-set! nfa i (cons (cons mst x) (vector-ref nfa i)))))

;; Compile and return the vector of NFA states (in groups of
;; *nfa-num-fields* packed elements).  The start state will be the
;; last element(s) of the vector, and all remaining states will be in
;; descending numeric order, with state 0 being the unique accepting
;; state.
(define (sre->nfa sre init-flags)
  (let ((buf (make-vector (* *nfa-presize* *nfa-num-fields*) '())))
    ;; we loop over an implicit sequence list
    (define (lp ls n flags next)
      (define (new-state-number state)
        (max n (+ 1 state)))
      (define (add-state! n2 trans-ls)
        (if (>= (* n2 *nfa-num-fields*) (vector-length buf))
            (let ((tmp (make-vector (* 2 (vector-length buf)) '())))
              (do ((i (- (vector-length buf) 1) (- i 1)))
                  ((< i 0))
                (vector-set! tmp i (vector-ref buf i)))
              (set! buf tmp)))
        (nfa-set-state-trans! buf n2 trans-ls)
        n2)
      (define (extend-state! next . trans)
        (and next
             (add-state! (new-state-number next)
                         (map (lambda (x) (cons x next)) trans))))
      (define (add-char-state! next ch)
        (let ((alt (char-altcase ch)))
          (if (and (flag-set? flags ~case-insensitive?) (not (eqv? ch alt)))
              (extend-state! next ch alt)
              (extend-state! next ch))))
      (if (null? ls)
          next
          (cond
           ((or (eq? 'epsilon (car ls)) (equal? "" (car ls)))
            ;; chars and epsilons go directly into the transition table
            (let ((next (lp (cdr ls) n flags next)))
              (and next
                   (let ((new (add-state! (new-state-number next) '())))
                     (nfa-add-epsilon! buf new next)
                     new))))
           ((string? (car ls))
            ;; process literal strings a char at a time
            (let ((next (lp (cdr ls) n flags next)))
              (and next
                   (let lp2 ((i (- (string-length (car ls)) 1))
                             (next next))
                     (if (< i 0)
                         next
                         (lp2 (- i 1)
                              (add-char-state! next (string-ref (car ls) i))))
                     ))))
           ((char? (car ls))
            (add-char-state! (lp (cdr ls) n flags next) (car ls)))
           ((symbol? (car ls))
            (let ((cell (assq (car ls) sre-named-definitions)))
              (and cell
                   (lp (cons (if (procedure? (cdr cell))
                                 ((cdr cell))
                                 (cdr cell))
                             (cdr ls))
                       n
                       flags
                       next))))
           ((pair? (car ls))
            (cond
             ((string? (caar ls))
              ;; enumerated character set
              (lp (cons (sre-alternate (string->list (caar ls))) (cdr ls))
                  n
                  flags
                  next))
             (else
              (case (caar ls)
                ((seq :)
                 ;; for an explicit sequence, just append to the list
                 (lp (append (cdar ls) (cdr ls)) n flags next))
                ((w/case w/nocase w/utf8 w/noutf8)
                 (let* ((next (lp (cdr ls) n flags next))
                        (flags ((if (memq (caar ls) '(w/case w/utf8))
                                    flag-clear
                                    flag-join)
                                flags
                                (if (memq (caar ls) '(w/case w/nocase))
                                    ~case-insensitive?
                                    ~utf8?))))
                   (and next
                        (lp (cdar ls) (new-state-number next) flags next))))
                ((/ - & ~) 
                 (let ((ranges
                        (sre->cset (car ls)
                                   (flag-set? flags ~case-insensitive?))))
                   (case (length ranges)
                     ((1)
                      (extend-state! (lp (cdr ls) n flags next) (car ranges)))
                     (else
                      (let ((next (lp (cdr ls) n flags next)))
                        (and
                         next
                         (lp (list (sre-alternate
                                    (map (lambda (x) (if (pair? x)
                                                     (list '/ (car x) (cdr x))
                                                     x))
                                         ranges)))
                             (new-state-number next)
                             (flag-clear flags ~case-insensitive?)
                             next)))))))
                ((or)
                 (let ((next (lp (cdr ls) n flags next)))
                   (and
                    next
                    (if (null? (cdar ls))
                        ;; empty (or) always fails
                        (add-state! (new-state-number next) '())
                        ;; compile both branches and insert epsilon
                        ;; transitions to either
                        (let* ((b (lp (list (sre-alternate (cddar ls)))
                                      (new-state-number next)
                                      flags
                                      next))
                               (a (and b
                                       (lp (list (cadar ls))
                                           (new-state-number (max b next))
                                           flags
                                           next))))
                          (and a
                               (let ((c (add-state! (new-state-number a) '())))
                                 (nfa-add-epsilon! buf c a)
                                 (nfa-add-epsilon! buf c b)
                                 c)))))))
                ((?)
                 (let ((next (lp (cdr ls) n flags next)))
                   ;; insert an epsilon transition directly to next
                   (and
                    next
                    (let ((a (lp (cdar ls) (new-state-number next) flags next)))
                      (if a
                          (nfa-add-epsilon! buf a next))
                      a))))
                ((+ *)
                 (let ((next (lp (cdr ls) n flags next)))
                   (and
                    next
                    (let* ((new (lp '(epsilon)
                                    (new-state-number next)
                                    flags
                                    next))
                           (a (lp (cdar ls) (new-state-number new) flags new)))
                      (cond
                       (a
                        ;; for *, insert an epsilon transition as in ? above
                        (if (eq? '* (caar ls))
                            (nfa-add-epsilon! buf a new))
                        ;; for both, insert a loop back to self
                        (nfa-add-epsilon! buf new a)))
                      a))))
                ;; need to add these to the match extractor first,
                ;; but they tend to generate large DFAs
                ;;((=)
                ;; (lp (append (vector->list
                ;;              (make-vector (cadar ls)
                ;;                           (sre-sequence (cddar ls))))
                ;;             (cdr ls))
                ;;     n flags next))
                ;;((>=)
                ;; (lp (append (vector->list
                ;;              (make-vector (- (cadar ls) 1)
                ;;                           (sre-sequence (cddar ls))))
                ;;             (cons `(+ ,@(cddar ls)) (cdr ls)))
                ;;     n flags next))
                ;;((**)
                ;; (lp (append (vector->list
                ;;              (make-vector (cadar ls)
                ;;                           (sre-sequence (cdddar ls))))
                ;;             (map
                ;;              (lambda (x) `(? ,x))
                ;;              (vector->list
                ;;               (make-vector (- (caddar ls) (cadar ls))
                ;;                            (sre-sequence (cdddar ls)))))
                ;;             (cdr ls))
                ;;     n flags next))
                 ;; ignore submatches altogether
                (($ submatch)
                 (lp (cons (sre-sequence (cdar ls)) (cdr ls)) n flags next))
                ((=> submatch-named)
                 (lp (cons (sre-sequence (cddar ls)) (cdr ls)) n flags next))
                (else
                 (cond
                  ((assq (caar ls) sre-named-definitions)
                   => (lambda (cell)
                        (if (procedure? (cdr cell))
                            (lp (cons (apply (cdr cell) (cdar ls)) (cdr ls))
                                n flags next)
                            (error "non-procedure in op position" (caar ls)))))
                  (else #f)))))))
           (else
            #f))))
    (let ((len (lp (list sre) 1 init-flags 0)))
      (and len
           (let ((nfa (make-vector (* *nfa-num-fields* (+ len 1)))))
             (do ((i (- (vector-length nfa) 1) (- i 1)))
                 ((< i 0))
               (vector-set! nfa i (vector-ref buf i)))
             nfa)))))

;; We don't really want to use this, we use the closure compilation
;; below instead, but this is included for reference and testing the
;; sre->nfa conversion.

;; (define (nfa-match nfa str)
;;   (let lp ((ls (string->list str)) (state (car nfa)) (epsilons '()))
;;     (if (null? ls)
;;         (zero? (car state))
;;         (any (lambda (m)
;;                (if (eq? 'epsilon (car m))
;;                    (and (not (memv (cdr m) epsilons))
;;                         (lp ls (assv (cdr m) nfa) (cons (cdr m) epsilons)))
;;                    (and (or (eqv? (car m) (car ls))
;;                             (and (pair? (car m))
;;                                  (char<=? (caar m) (car ls))
;;                                  (char<=? (car ls) (cdar m))))
;;                         (lp (cdr ls) (assv (cdr m) nfa) '()))))
;;              (cdr state)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NFA multi-state representation

;; Cache closures in a simple hash-table keyed on the smallest state
;; (define (nfa-multi-state-hash nfa mst)
;;   (car mst))

;; Original sorted list-based representation

;; (define (make-nfa-multi-state nfa)
;;   '())

;; (define (nfa-state->multi-state nfa state)
;;   (list state))

;; (define (nfa-multi-state-copy mst)
;;   (map (lambda (x) x) mst))

;; (define (list->nfa-multi-state nfa ls)
;;   (nfa-multi-state-copy ls))

;; (define (nfa-multi-state-contains? mst i)
;;   (memq i mst))

;; (define (nfa-multi-state-fold mst kons knil)
;;   (fold kons knil mst))

;; (define (nfa-multi-state-add! mst i)
;;   (insert-sorted i mst))

;; (define (nfa-multi-state-add mst i)
;;   (insert-sorted i mst))

;; (define (nfa-multi-state-union a b)
;;   (merge-sorted a b))

;; Sorted List Utilities

;; (define (insert-sorted n ls)
;;   (cond
;;    ((null? ls)
;;     (cons n '()))
;;    ((<= n (car ls))
;;     (if (= n (car ls))
;;         ls
;;         (cons n ls)))
;;    (else
;;     (cons (car ls) (insert-sorted n (cdr ls))))))

;; (define (insert-sorted! n ls)
;;   (cond
;;    ((null? ls)
;;     (cons n '()))
;;    ((<= n (car ls))
;;     (if (= n (car ls))
;;         ls
;;         (cons n ls)))
;;    (else
;;     (let lp ((head ls) (tail (cdr ls)))
;;       (cond ((or (null? tail) (< n (car tail)))
;;              (set-cdr! head (cons n tail)))
;;             ((> n (car tail))
;;              (lp tail (cdr tail)))))
;;     ls)))

;; (define (merge-sorted a b)
;;   (cond ((null? a) b)
;;         ((null? b) a)
;;         ((< (car a) (car b))
;;          (cons (car a) (merge-sorted (cdr a) b)))
;;         ((> (car a) (car b))
;;          (cons (car b) (merge-sorted a (cdr b))))
;;         (else (merge-sorted (cdr a) b))))

;; ========================================================= ;;

;; Presized bit-vector based

(define (nfa-multi-state-hash nfa mst)
  (modulo (vector-ref mst 0) (nfa-num-states nfa)))

(define (make-nfa-multi-state nfa)
  (make-vector (quotient (+ (nfa-num-states nfa) 24 -1) 24) 0))

(define (nfa-state->multi-state nfa state)
  (nfa-multi-state-add! (make-nfa-multi-state nfa) state))

(define (nfa-multi-state-copy mst)
  (let ((res (make-vector (vector-length mst))))
    (do ((i (- (vector-length mst) 1) (- i 1)))
        ((< i 0) res)
      (vector-set! res i (vector-ref mst i)))))

(define (nfa-multi-state-contains? mst i)
  (let ((cell (quotient i 24))
        (bit (remainder i 24)))
    (not (zero? (bit-and (vector-ref mst cell) (bit-shl 1 bit))))))

(define (nfa-multi-state-add! mst i)
  (let ((cell (quotient i 24))
        (bit (remainder i 24)))
    (vector-set! mst cell (bit-ior (vector-ref mst cell) (bit-shl 1 bit)))
    mst))

(define (nfa-multi-state-add mst i)
  (nfa-multi-state-add! (nfa-multi-state-copy mst) i))

(define (nfa-multi-state-union! a b)
  (do ((i (- (vector-length a) 1) (- i 1)))
      ((< i 0) a)
    (vector-set! a i (bit-ior (vector-ref a i) (vector-ref b i)))))

(define (nfa-multi-state-union a b)
  (nfa-multi-state-union! (nfa-multi-state-copy a) b))

(define (nfa-multi-state-fold mst kons knil)
  (let ((limit (vector-length mst)))
    (let lp1 ((i 0)
              (acc knil))
      (if (>= i limit)
          acc
          (let lp2 ((n (vector-ref mst i))
                    (acc acc))
            (if (zero? n)
                (lp1 (+ i 1) acc)
                (let* ((n2 (bit-and n (- n 1)))
                       (n-tail (- n n2))
                       (bit (+ (* i 24) (integer-log n-tail))))
                  (lp2 n2 (kons bit acc)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; NFA->DFA compilation
;;
;; During processing, the DFA is a list of the form:
;;
;;   ((NFA-states ...) accepting-state? transitions ...)
;;
;; where the transitions are as in the NFA, except there are no
;; epsilons, duplicate characters or overlapping char-set ranges, and
;; the states moved to are closures (sets of NFA states).  Multiple
;; DFA states may be accepting states.

(define (nfa->dfa nfa . o)
  (let ((max-states (and (pair? o) (car o))))
    (let lp ((ls (list (nfa-cache-state-closure! nfa (nfa-start-state nfa))))
             (i 0)
             (res '()))
      (cond
       ((null? ls)
        (dfa-renumber nfa (reverse res)))
       ((assoc (car ls) res) ;; already seen this combination of states
        (lp (cdr ls) i res))
       ((and max-states (> i max-states)) ;; too many DFA states
        #f)
       (else
        (let* ((states (car ls))
               (trans (nfa-state-transitions nfa states))
               (accept? (and (nfa-multi-state-contains? states 0) #t)))
          (lp (append (map cdr trans) (cdr ls))
              (+ i 1)
              `((,states ,accept? ,@trans) ,@res))))))))

;; When the conversion is complete we renumber the DFA sets-of-states
;; in order and convert the result to a vector for fast lookup.
(define (dfa-renumber nfa dfa)
  (let* ((len (length dfa))
         (states (make-vector (nfa-num-states nfa) '()))
         (res (make-vector len)))
    (define (renumber mst)
      (cdr (assoc mst (vector-ref states (nfa-multi-state-hash nfa mst)))))
    (let lp ((ls dfa) (i 0))
      (cond ((pair? ls)
             (let ((j (nfa-multi-state-hash nfa (caar ls))))
               (vector-set! states j (cons (cons (caar ls) i)
                                           (vector-ref states j))))
             (lp (cdr ls) (+ i 1)))))
    (let lp ((ls dfa) (i 0))
      (cond ((pair? ls)
             (for-each
              (lambda (x) (set-cdr! x (renumber (cdr x))))
              (cddar ls))
             (vector-set! res i (cdar ls))
             (lp (cdr ls) (+ i 1)))))
    res))

;; Extract all distinct characters or ranges and the potential states
;; they can transition to from a given set of states.  Any ranges that
;; would overlap with distinct characters are split accordingly.
(define (nfa-state-transitions nfa states)
  (let ((res (nfa-multi-state-fold
              states
              (lambda (st res)
                (fold (lambda (trans res)
                        (nfa-join-transitions! nfa res (car trans) (cdr trans)))
                      res
                      (nfa-get-state-trans nfa st)))
              '())))
    (for-each (lambda (x) (set-cdr! x (nfa-closure nfa (cdr x)))) res)
    res))

(define (nfa-join-transitions! nfa existing elt state)
  (define (join! ls elt state)
    (if (not elt)
        ls
        (nfa-join-transitions! nfa ls elt state)))
  (cond
   ((char? elt)
    (let lp ((ls existing) (res '()))
      (cond
       ((null? ls)
        ;; done, just cons this on to the original list
        (cons (cons elt (nfa-state->multi-state nfa state)) existing))
       ((eq? elt (caar ls))
        ;; add a new state to an existing char
        (set-cdr! (car ls) (nfa-multi-state-add! (cdar ls) state))
        existing)
       ((and (pair? (caar ls))
             (char<=? (caaar ls) elt)
             (char<=? elt (cdaar ls)))
        ;; split a range
        (apply
         (lambda (left right)
           (let ((left-copy (nfa-multi-state-copy (cdar ls)))
                 (right-copy (nfa-multi-state-copy (cdar ls))))
             (cons (cons elt (nfa-multi-state-add! (cdar ls) state))
                   (append (if left (list (cons left left-copy)) '())
                           (if right (list (cons right right-copy)) '())
                           res
                           (cdr ls)))))
         (split-char-range (caar ls) elt)))
       (else
        ;; keep looking
        (lp (cdr ls) (cons (car ls) res))))))
   (else
    (let ((lo (car elt))
          (hi (cdr elt)))
      (let lp ((ls existing) (res '()))
        (cond
         ((null? ls)
          ;; done, just cons this on to the original list
          (cons (cons elt (nfa-state->multi-state nfa state)) existing))
         ((and (char? (caar ls)) (char<=? lo (caar ls)) (char<=? (caar ls) hi))
          ;; range enclosing a character
          (apply
           (lambda (left right)
             (set-cdr! (car ls) (nfa-multi-state-add! (cdar ls) state))
             (join! (join! existing left state) right state))
           (split-char-range elt (caar ls))))
         ((and (pair? (caar ls))
               (or (and (char<=? (caaar ls) hi) (char<=? lo (cdaar ls)))
                   (and (char<=? hi (caaar ls)) (char<=? (cdaar ls) lo))))
          ;; overlapping ranges
          (apply
           (lambda (left1 left2 same right1 right2) ;; 5 regions
             (let ((right1-copy (nfa-multi-state-copy (cdar ls)))
                   (right2-copy (nfa-multi-state-copy (cdar ls))))
               (set-car! (car ls) same)
               (set-cdr! (car ls) (nfa-multi-state-add! (cdar ls) state))
               (let* ((res (if right1
                               (cons (cons right1 right1-copy) existing)
                               existing))
                      (res (if right2
                               (cons (cons right2 right2-copy) res)
                               res)))
                 (join! (join! res left1 state) left2 state))))
           (intersect-char-ranges elt (caar ls))))
         (else
          (lp (cdr ls) (cons (car ls) res)))))))))

(define (char-range c1 c2)
  (if (eqv? c1 c2) c1 (cons c1 c2)))

;; assumes ch is included in the range
(define (split-char-range range ch)
  (list
   (and (not (eqv? ch (car range)))
        (char-range (car range) (integer->char (- (char->integer ch) 1))))
   (and (not (eqv? ch (cdr range)))
        (char-range (integer->char (+ (char->integer ch) 1)) (cdr range)))))

;; returns 5 (possibly #f) char ranges:
;;    a-only-1  a-only-2  a-and-b  b-only-1  b-only-2
(define (intersect-char-ranges a b)
  (if (char>? (car a) (car b))
      (reverse (intersect-char-ranges b a))
      (let ((a-lo (car a))
            (a-hi (cdr a))
            (b-lo (car b))
            (b-hi (cdr b)))
        (list
         (and (char<? a-lo b-lo)
              (char-range a-lo (integer->char (- (char->integer b-lo) 1))))
         (and (char>? a-hi b-hi)
              (char-range (integer->char (+ (char->integer b-hi) 1)) a-hi))
         (char-range b-lo (if (char<? b-hi a-hi) b-hi a-hi))
         #f
         (and (char>? b-hi a-hi)
              (char-range (integer->char (+ (char->integer a-hi) 1)) b-hi))))))

(define (nfa-cache-state-closure! nfa state)
  (let ((cached (nfa-get-state-closure nfa state)))
    (cond
     ((not (null? cached))
      cached)
     (else
      (let ((res (nfa-state-closure-internal nfa state)))
        (nfa-set-state-closure! nfa state res)
        res)))))

;; The `closure' of a list of NFA states - all states that can be
;; reached from any of them using any number of epsilon transitions.
(define (nfa-state-closure-internal nfa state)
  (let lp ((ls (list state))
           (res (make-nfa-multi-state nfa)))
    (cond
     ((null? ls)
      res)
     ((nfa-multi-state-contains? res (car ls))
      (lp (cdr ls) res))
     (else
      (lp (append (nfa-get-epsilons nfa (car ls)) (cdr ls))
          (nfa-multi-state-add! res (car ls)))))))

(define (nfa-closure-internal nfa states)
  (nfa-multi-state-fold
   states
   (lambda (st res)
     (nfa-multi-state-union! res (nfa-cache-state-closure! nfa st)))
   (make-nfa-multi-state nfa)))

(define (nfa-closure nfa states)
  (or (nfa-get-closure nfa states)
      (let ((res (nfa-closure-internal nfa states)))
        (nfa-add-closure! nfa states res)
        res)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Match Extraction
;;
;; DFAs don't give us match information, so once we match and
;; determine the start and end, we need to recursively break the
;; problem into smaller DFAs to get each submatch.
;;
;; See http://compilers.iecc.com/comparch/article/07-10-026

(define (sre-match-extractor sre num-submatches)
  (let* ((tmp (+ num-submatches 1))
         (tmp-end-src-offset (+ 5 (* tmp 4)))
         (tmp-end-index-offset (+ 6 (* tmp 4))))
    (let lp ((sre sre) (n 1) (submatch-deps? #f))
      (cond
       ((not (sre-has-submatches? sre))
        (if (not submatch-deps?)
            (lambda (cnk start i end j matches) #t)
            (let ((dfa (nfa->dfa (sre->nfa sre ~none))))
              (lambda (cnk start i end j matches)
                (dfa-match/longest dfa cnk start i end j matches tmp)))))
       ((pair? sre)
        (case (car sre)
          ((: seq)
           (let* ((right (sre-sequence (cddr sre)))
                  (match-left (lp (cadr sre) n #t))
                  (match-right
                   (lp right (+ n (sre-count-submatches (cadr sre))) #t)))
             (lambda (cnk start i end j matches)
               (let lp1 ((end2 end) (j2 j) (best-src #f) (best-index #f))
                 (let ((limit (if (eq? start end2)
                                  i
                                  ((chunker-get-start cnk) end2))))
                   (let lp2 ((k j2) (best-src best-src) (best-index best-index))
                     (if (< k limit)
                         (cond
                          ((not (eq? start end2))
                           (let ((prev (chunker-prev-chunk cnk start end2)))
                             (lp1 prev
                                  ((chunker-get-end cnk) prev)
                                  best-src
                                  best-index)))
                          (best-src
                           (vector-set! matches tmp-end-src-offset best-src)
                           (vector-set! matches tmp-end-index-offset best-index)
                           #t)
                          (else
                           #f))
                         (if (and (match-left cnk start i end2 k matches)
                                  (eq? end2 (vector-ref matches
                                                        tmp-end-src-offset))
                                  (eqv? k (vector-ref matches
                                                      tmp-end-index-offset))
                                  (match-right cnk end2 k end j matches))
                             (let ((right-src
                                    (vector-ref matches tmp-end-src-offset))
                                   (right
                                    (vector-ref matches tmp-end-index-offset)))
                               (cond
                                ((and (eq? end right-src) (eqv? j right))
                                 (vector-set! matches tmp-end-src-offset end)
                                 (vector-set! matches tmp-end-index-offset j)
                                 #t)
                                ((or (not best-src)
                                     (if (eq? best-src right-src)
                                         (> right best-index)
                                         (chunk-before? cnk
                                                        best-src
                                                        right-src)))
                                 (lp2 (- k 1) right-src right))
                                (else
                                 (lp2 (- k 1) best-src best-index))))
                             (lp2 (- k 1) best-src best-index)))))))))
          ((or)
           (if (null? (cdr sre))
               (lambda (cnk start i end j matches) #f)
               (let* ((rest (sre-alternate (cddr sre)))
                      (match-first
                       (lp (cadr sre) n #t))
                      (match-rest
                       (lp rest
                           (+ n (sre-count-submatches (cadr sre)))
                           submatch-deps?)))
                 (lambda (cnk start i end j matches)
                   (or (and (match-first cnk start i end j matches)
                            (eq? end (vector-ref matches tmp-end-src-offset))
                            (eqv? j (vector-ref matches tmp-end-index-offset)))
                       (match-rest cnk start i end j matches))))))
          ((* +)
           (letrec ((match-once
                     (lp (sre-sequence (cdr sre)) n #t))
                    (match-all
                     (lambda (cnk start i end j matches)
                       (if (match-once cnk start i end j matches)
                           (let ((src (vector-ref matches tmp-end-src-offset))
                                 (k (vector-ref matches tmp-end-index-offset)))
                             (if (and src (or (not (eq? start src)) (< i k)))
                                 (match-all cnk src k end j matches)
                                 #t))
                           (begin
                             (vector-set! matches tmp-end-src-offset start)
                             (vector-set! matches tmp-end-index-offset i)
                             #t)))))
             (if (eq? '* (car sre))
                 match-all
                 (lambda (cnk start i end j matches)
                   (and (match-once cnk start i end j matches)
                        (let ((src (vector-ref matches tmp-end-src-offset))
                              (k (vector-ref matches tmp-end-index-offset)))
                          (match-all cnk src k end j matches)))))))
          ((?)
           (let ((match-once (lp (sre-sequence (cdr sre)) n #t)))
             (lambda (cnk start i end j matches)
               (match-once cnk start i end j matches)
               #t)))
          (($ submatch => submatch-named)
           (let ((match-one
                  (lp (sre-sequence (if (memq (car sre) '($ submatch))
                                        (cdr sre)
                                        (cddr sre)))
                      (+ n 1)
                      #t))
                 (start-src-offset (+ 3 (* n 4)))
                 (start-index-offset (+ 4 (* n 4)))
                 (end-src-offset (+ 5 (* n 4)))
                 (end-index-offset (+ 6 (* n 4))))
             (lambda (cnk start i end j matches)
               (cond
                ((match-one cnk start i end j matches)
                 (vector-set! matches start-src-offset start)
                 (vector-set! matches start-index-offset i)
                 (vector-set! matches end-src-offset
                              (vector-ref matches tmp-end-src-offset))
                 (vector-set! matches end-index-offset
                              (vector-ref matches tmp-end-index-offset))
                 #t)
                (else
                 #f)))))
          (else
           (error "unknown regexp operator" (car sre)))))
       (else
        (error "unknown regexp" sre))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Closure Compilation
;;
;; We use this for non-regular expressions instead of an interpreted
;; NFA matcher.  We use backtracking anyway, but this gives us more
;; freedom of implementation, allowing us to support patterns that
;; can't be represented in the above NFA representation.

(define (sre->procedure sre . o)
  (define names
    (if (and (pair? o) (pair? (cdr o))) (cadr o) (sre-names sre 1 '())))
  (let lp ((sre sre)
           (n 1)
           (flags (if (pair? o) (car o) ~none))
           (next (lambda (cnk init src str i end matches fail)
                   (irregex-match-start-chunk-set! matches 0 (car init))
                   (irregex-match-start-index-set! matches 0 (cdr init))
                   (irregex-match-end-chunk-set! matches 0 src)
                   (irregex-match-end-index-set! matches 0 i)
                   (%irregex-match-fail-set! matches fail)
                   matches)))
    ;; XXXX this should be inlined
    (define (rec sre) (lp sre n flags next))
    (cond
     ((pair? sre)
      (if (string? (car sre))
          (sre-cset->procedure
           (sre->cset (car sre) (flag-set? flags ~case-insensitive?))
           next)
          (case (car sre)
            ((~ - & /)
             (sre-cset->procedure
              (sre->cset sre (flag-set? flags ~case-insensitive?))
              next))
            ((or)
             (case (length (cdr sre))
               ((0) (lambda (cnk init src str i end matches fail) (fail)))
               ((1) (rec (cadr sre)))
               (else
                (let* ((first (rec (cadr sre)))
                       (rest (lp (sre-alternate (cddr sre))
                                 (+ n (sre-count-submatches (cadr sre)))
                                 flags
                                 next)))
                  (lambda (cnk init src str i end matches fail)
                    (first cnk init src str i end matches
                           (lambda ()
                             (rest cnk init src str i end matches fail))))))))
            ((w/case)
             (lp (sre-sequence (cdr sre))
                 n
                 (flag-clear flags ~case-insensitive?)
                 next))
            ((w/nocase)
             (lp (sre-sequence (cdr sre))
                 n
                 (flag-join flags ~case-insensitive?)
                 next))
            ((w/utf8)
             (lp (sre-sequence (cdr sre)) n (flag-join flags ~utf8?) next))
            ((w/noutf8)
             (lp (sre-sequence (cdr sre)) n (flag-clear flags ~utf8?) next))
            ((seq :)
             (case (length (cdr sre))
               ((0) next)
               ((1) (rec (cadr sre)))
               (else
                (let ((rest (lp (sre-sequence (cddr sre))
                                (+ n (sre-count-submatches (cadr sre)))
                                flags
                                next)))
                  (lp (cadr sre) n flags rest)))))
            ((?)
             (let ((body (rec (sre-sequence (cdr sre)))))
               (lambda (cnk init src str i end matches fail)
                 (body cnk init src str i end matches
                       (lambda () (next cnk init src str i end matches fail))))))
            ((??)
             (let ((body (rec (sre-sequence (cdr sre)))))
               (lambda (cnk init src str i end matches fail)
                 (next cnk init src str i end matches
                       (lambda () (body cnk init src str i end matches fail))))))
            ((*)
             (cond
              ((sre-empty? (sre-sequence (cdr sre)))
               (error "invalid sre: empty *" sre))
              (else
               (letrec
                   ((body
                     (lp (sre-sequence (cdr sre))
                         n
                         flags
                         (lambda (cnk init src str i end matches fail)
                           (body cnk init src str i end matches
                                 (lambda ()
                                   (next cnk init src str i end matches fail)
                                   ))))))
                 (lambda (cnk init src str i end matches fail)
                   (body cnk init src str i end matches
                         (lambda ()
                           (next cnk init src str i end matches fail))))))))
            ((*?)
             (cond
              ((sre-empty? (sre-sequence (cdr sre)))
               (error "invalid sre: empty *?" sre))
              (else
               (letrec
                   ((body
                     (lp (sre-sequence (cdr sre))
                         n
                         flags
                         (lambda (cnk init src str i end matches fail)
                           (next cnk init src str i end matches
                                 (lambda ()
                                   (body cnk init src str i end matches fail)
                                   ))))))
                 (lambda (cnk init src str i end matches fail)
                   (next cnk init src str i end matches
                         (lambda ()
                           (body cnk init src str i end matches fail))))))))
            ((+)
             (lp (sre-sequence (cdr sre))
                 n
                 flags
                 (rec (list '* (sre-sequence (cdr sre))))))
            ((=)
             (rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
            ((>=)
             (rec `(** ,(cadr sre) #f ,@(cddr sre))))
            ((** **?)
             (cond
              ((or (and (number? (cadr sre))
                        (number? (caddr sre))
                        (> (cadr sre) (caddr sre)))
                   (and (not (cadr sre)) (caddr sre)))
               (lambda (cnk init src str i end matches fail) (fail)))
              (else
               (let* ((from (cadr sre))
                      (to (caddr sre))
                      (? (if (eq? '** (car sre)) '? '??))
                      (* (if (eq? '** (car sre)) '* '*?))
                      (sre (sre-sequence (cdddr sre)))
                      (x-sre (sre-strip-submatches sre))
                      (next (if to
                                (if (= from to)
                                    next
                                    (fold (lambda (x next)
                                            (lp `(,? ,sre) n flags next))
                                          next
                                          (zero-to (- to from))))
                                (rec `(,* ,sre)))))
                 (if (zero? from)
                     next
                     (lp `(seq ,@(map (lambda (x) x-sre) (zero-to (- from 1)))
                               ,sre)
                         n
                         flags
                         next))))))
            ((word)
             (rec `(seq bow ,@(cdr sre) eow)))
            ((word+)
             (rec `(seq bow (+ (& (or alphanumeric "_")
                                  (or ,@(cdr sre)))) eow)))
            ((posix-string)
             (rec (string->sre (cadr sre))))
            ((look-ahead)
             (let ((check
                    (lp (sre-sequence (cdr sre))
                        n
                        flags
                        (lambda (cnk init src str i end matches fail) i))))
               (lambda (cnk init src str i end matches fail)
                 (if (check cnk init src str i end matches (lambda () #f))
                     (next cnk init src str i end matches fail)
                     (fail)))))
            ((neg-look-ahead)
             (let ((check
                    (lp (sre-sequence (cdr sre))
                        n
                        flags
                        (lambda (cnk init src str i end matches fail) i))))
               (lambda (cnk init src str i end matches fail)
                 (if (check cnk init src str i end matches (lambda () #f))
                     (fail)
                     (next cnk init src str i end matches fail)))))
            ((look-behind neg-look-behind)
             (let ((check
                    (lp (sre-sequence
                         (cons '(* any) (append (cdr sre) '(eos))))
                        n
                        flags
                        (lambda (cnk init src str i end matches fail) i))))
               (lambda (cnk init src str i end matches fail)
                 (let* ((prev ((chunker-get-substring cnk)
                               (car init)
                               (cdr init)
                               src
                               i))
                        (len (string-length prev))
                        (src2 (list prev 0 len)))
                   (if ((if (eq? (car sre) 'look-behind) (lambda (x) x) not)
                        (check irregex-basic-string-chunker
                               (cons src2 0) src2 prev 0 len matches (lambda () #f)))
                       (next cnk init src str i end matches fail)
                       (fail))))))
            ((atomic)
             (let ((once
                    (lp (sre-sequence (cdr sre))
                        n
                        flags
                        (lambda (cnk init src str i end matches fail) i))))
               (lambda (cnk init src str i end matches fail)
                 (let ((j (once cnk init src str i end matches (lambda () #f))))
                   (if j
                       (next cnk init src str j end matches fail)
                       (fail))))))
            ((if)
             (let* ((test-submatches (sre-count-submatches (cadr sre)))
                    (pass (lp (caddr sre) flags (+ n test-submatches) next))
                    (fail (if (pair? (cdddr sre))
                              (lp (cadddr sre)
                                  (+ n test-submatches
                                     (sre-count-submatches (caddr sre)))
                                  flags
                                  next)
                              (lambda (cnk init src str i end matches fail)
                                (fail)))))
               (cond
                ((or (number? (cadr sre)) (symbol? (cadr sre)))
                 (let ((index
                        (if (symbol? (cadr sre))
                            (cond
                             ((assq (cadr sre) names) => cdr)
                             (else
                              (error "unknown named backref in SRE IF" sre)))
                            (cadr sre))))
                   (lambda (cnk init src str i end matches fail2)
                     (if (%irregex-match-end-chunk matches index)
                         (pass cnk init src str i end matches fail2)
                         (fail cnk init src str i end matches fail2)))))
                (else
                 (let ((test (lp (cadr sre) n flags pass)))
                   (lambda (cnk init src str i end matches fail2)
                     (test cnk init src str i end matches
                           (lambda () (fail cnk init src str i end matches fail2)))
                     ))))))
            ((backref backref-ci)
             (let ((n (cond ((number? (cadr sre)) (cadr sre))
                            ((assq (cadr sre) names) => cdr)
                            (else (error "unknown backreference" (cadr sre)))))
                   (compare (if (or (eq? (car sre) 'backref-ci)
                                    (flag-set? flags ~case-insensitive?))
                                string-ci=?
                                string=?)))
               (lambda (cnk init src str i end matches fail)
                 (let ((s (irregex-match-substring matches n)))
                   (if (not s)
                       (fail)
                       ;; XXXX create an abstract subchunk-compare
                       (let lp ((src src)
                                (str str)
                                (i i)
                                (end end)
                                (j 0)
                                (len (string-length s)))
                         (cond
                          ((<= len (- end i))
                           (cond
                            ((compare (substring s j (string-length s))
                                      (substring str i (+ i len)))
                             (next cnk init src str (+ i len) end matches fail))
                            (else
                             (fail))))
                          (else
                           (cond
                            ((compare (substring s j (+ j (- end i)))
                                      (substring str i end))
                             (let ((src2 ((chunker-get-next cnk) src)))
                               (if src2
                                   (lp src2
                                       ((chunker-get-str cnk) src2)
                                       ((chunker-get-start cnk) src2)
                                       ((chunker-get-end cnk) src2)
                                       (+ j (- end i))
                                       (- len (- end i)))
                                   (fail))))
                            (else
                             (fail)))))))))))
            ((dsm)
             (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) flags next))
            (($ submatch)
             (let ((body
                    (lp (sre-sequence (cdr sre))
                        (+ n 1)
                        flags
                        (lambda (cnk init src str i end matches fail)
                          (let ((old-source
                                 (%irregex-match-end-chunk matches n))
                                (old-index
                                 (%irregex-match-end-index matches n)))
                            (irregex-match-end-chunk-set! matches n src)
                            (irregex-match-end-index-set! matches n i)
                            (next cnk init src str i end matches
                                  (lambda ()
                                    (irregex-match-end-chunk-set!
                                     matches n old-source)
                                    (irregex-match-end-index-set!
                                     matches n old-index)
                                    (fail))))))))
               (lambda (cnk init src str i end matches fail)
                 (let ((old-source (%irregex-match-start-chunk matches n))
                       (old-index (%irregex-match-start-index matches n)))
                   (irregex-match-start-chunk-set! matches n src)
                   (irregex-match-start-index-set! matches n i)
                   (body cnk init src str i end matches
                         (lambda ()
                           (irregex-match-start-chunk-set!
                            matches n old-source)
                           (irregex-match-start-index-set!
                            matches n old-index)
                           (fail)))))))
            ((=> submatch-named)
             (rec `(submatch ,@(cddr sre))))
            (else
             (error "unknown regexp operator" sre)))))
     ((symbol? sre)
      (case sre
        ((any)
         (lambda (cnk init src str i end matches fail)
           (if (< i end)
               (next cnk init src str (+ i 1) end matches fail)
               (let ((src2 ((chunker-get-next cnk) src)))
                 (if src2
                     (let ((str2 ((chunker-get-str cnk) src2))
                           (i2 ((chunker-get-start cnk) src2))
                           (end2 ((chunker-get-end cnk) src2)))
                       (next cnk init src2 str2 (+ i2 1) end2 matches fail))
                     (fail))))))
        ((nonl)
         (lambda (cnk init src str i end matches fail)
           (if (< i end)
               (if (not (eqv? #\newline (string-ref str i)))
                   (next cnk init src str (+ i 1) end matches fail)
                   (fail))
               (let ((src2 ((chunker-get-next cnk) src)))
                 (if src2
                     (let ((str2 ((chunker-get-str cnk) src2))
                           (i2 ((chunker-get-start cnk) src2))
                           (end2 ((chunker-get-end cnk) src2)))
                       (if (not (eqv? #\newline (string-ref str2 i2)))
                           (next cnk init src2 str2 (+ i2 1) end2 matches fail)
                           (fail)))
                     (fail))))))
        ((bos)
         (lambda (cnk init src str i end matches fail)
           (if (and (eq? src (car init)) (eqv? i (cdr init)))
               (next cnk init src str i end matches fail)
               (fail))))
        ((bol)
         (lambda (cnk init src str i end matches fail)
           (if (or (and (eq? src (car init)) (eqv? i (cdr init)))
                   (and (> i ((chunker-get-start cnk) src))
                        (eqv? #\newline (string-ref str (- i 1)))))
               (next cnk init src str i end matches fail)
               (fail))))
        ((bow)
         (lambda (cnk init src str i end matches fail)
           (if (and (or (if (> i ((chunker-get-start cnk) src))
                            (not (char-alphanumeric? (string-ref str (- i 1))))
                            (let ((ch (chunker-prev-char cnk src end)))
                              (and ch (not (char-alphanumeric? ch)))))
                        (and (eq? src (car init)) (eqv? i (cdr init))))
                    (if (< i end)
                        (char-alphanumeric? (string-ref str i))
                        (let ((next ((chunker-get-next cnk) src)))
                          (and next
                               (char-alphanumeric?
                                (string-ref ((chunker-get-str cnk) next)
                                            ((chunker-get-start cnk) next)))))))
               (next cnk init src str i end matches fail)
               (fail))))
        ((eos)
         (lambda (cnk init src str i end matches fail)
           (if (and (>= i end) (not ((chunker-get-next cnk) src)))
               (next cnk init src str i end matches fail)
               (fail))))
        ((eol)
         (lambda (cnk init src str i end matches fail)
           (if (if (< i end)
                   (eqv? #\newline (string-ref str i))
                   (let ((src2 ((chunker-get-next cnk) src)))
                     (if (not src2)
                         #t
                         (eqv? #\newline
                               (string-ref ((chunker-get-str cnk) src2)
                                           ((chunker-get-start cnk) src2))))))
               (next cnk init src str i end matches fail)
               (fail))))
        ((eow)
         (lambda (cnk init src str i end matches fail)
           (if (and (if (< i end)
                        (not (char-alphanumeric? (string-ref str i)))
                        (let ((ch (chunker-next-char cnk src)))
                          (or (not ch) (not (char-alphanumeric? ch)))))
                    (if (> i ((chunker-get-start cnk) src))
                        (char-alphanumeric? (string-ref str (- i 1)))
                        (let ((prev (chunker-prev-char cnk init src)))
                          (or (not prev) (char-alphanumeric? prev)))))
               (next cnk init src str i end matches fail)
               (fail))))
        ((nwb)  ;; non-word-boundary
         (lambda (cnk init src str i end matches fail)
           (let ((c1 (if (< i end)
                         (string-ref str i)
                         (chunker-next-char cnk src)))
                 (c2 (if (> i ((chunker-get-start cnk) src))
                         (string-ref str (- i 1))
                         (chunker-prev-char cnk init src))))
             (if (and c1 c2
                      (if (char-alphanumeric? c1)
                          (char-alphanumeric? c2)
                          (not (char-alphanumeric? c2))))
                 (next cnk init src str i end matches fail)
                 (fail)))))
        ((epsilon)
         next)
        (else
         (let ((cell (assq sre sre-named-definitions)))
           (if cell
               (rec (cdr cell))
               (error "unknown regexp" sre))))))
     ((char? sre)
      (if (flag-set? flags ~case-insensitive?)
          ;; case-insensitive
          (lambda (cnk init src str i end matches fail)
            (if (>= i end)
                (let lp ((src2 ((chunker-get-next cnk) src)))
                  (if src2
                      (let ((str2 ((chunker-get-str cnk) src2))
                            (i2 ((chunker-get-start cnk) src2))
                            (end2 ((chunker-get-end cnk) src2)))
                        (if (>= i2 end2)
                            (lp ((chunker-get-next cnk) src2))
                            (if (char-ci=? sre (string-ref str2 i2))
                                (next cnk init src2 str2 (+ i2 1) end2
                                      matches fail)
                                (fail))))
                      (fail)))
                (if (char-ci=? sre (string-ref str i))
                    (next cnk init src str (+ i 1) end matches fail)
                    (fail))))
          ;; case-sensitive
          (lambda (cnk init src str i end matches fail)
            (if (>= i end)
                (let lp ((src2 ((chunker-get-next cnk) src)))
                  (if src2
                      (let ((str2 ((chunker-get-str cnk) src2))
                            (i2 ((chunker-get-start cnk) src2))
                            (end2 ((chunker-get-end cnk) src2)))
                        (if (>= i2 end2)
                            (lp ((chunker-get-next cnk) src2))
                            (if (char=? sre (string-ref str2 i2))
                                (next cnk init src2 str2 (+ i2 1) end2
                                      matches fail)
                                (fail))))
                      (fail)))
                (if (char=? sre (string-ref str i))
                    (next cnk init src str (+ i 1) end matches fail)
                    (fail))))
          ))
     ((string? sre)
      (rec (sre-sequence (string->list sre)))
;; XXXX reintroduce faster string matching on chunks
;;       (if (flag-set? flags ~case-insensitive?)
;;           (rec (sre-sequence (string->list sre)))
;;           (let ((len (string-length sre)))
;;             (lambda (cnk init src str i end matches fail)
;;               (if (and (<= (+ i len) end)
;;                        (%substring=? sre str 0 i len))
;;                   (next str (+ i len) matches fail)
;;                   (fail)))))
      )
     (else
      (error "unknown regexp" sre)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Character Sets
;;
;; Simple character sets as lists of ranges, as used in the NFA/DFA
;; compilation.  This is not especially efficient, but is portable and
;; scalable for any range of character sets.

(define (sre-cset->procedure cset next)
  (lambda (cnk init src str i end matches fail)
    (if (< i end)
        (if (cset-contains? cset (string-ref str i))
            (next cnk init src str (+ i 1) end matches fail)
            (fail))
        (let ((src2 ((chunker-get-next cnk) src)))
          (if src2
              (let ((str2 ((chunker-get-str cnk) src2))
                    (i2 ((chunker-get-start cnk) src2))
                    (end2 ((chunker-get-end cnk) src2)))
                (if (cset-contains? cset (string-ref str2 i2))
                    (next cnk init src2 str2 (+ i2 1) end2 matches fail)
                    (fail)))
              (fail))))))

(define (plist->alist ls)
  (let lp ((ls ls) (res '()))
    (if (null? ls)
        (reverse res)
        (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res)))))

(define (alist->plist ls)
  (let lp ((ls ls) (res '()))
    (if (null? ls)
        (reverse res)
        (lp (cdr ls) (cons (cdar ls) (cons (caar ls) res))))))

(define (sre->cset sre . o)
  (let lp ((sre sre) (ci? (and (pair? o) (car o))))
    (define (rec sre) (lp sre ci?))
    (cond
     ((pair? sre)
      (if (string? (car sre))
          (if ci?
              (cset-case-insensitive (string->list (car sre)))
              (string->list (car sre)))
          (case (car sre)
            ((~)
             (cset-complement
              (fold cset-union (rec (cadr sre)) (map rec (cddr sre)))))
            ((&)
             (fold cset-intersection (rec (cadr sre)) (map rec (cddr sre))))
            ((-)
             (fold (lambda (x res) (cset-difference res x))
                   (rec (cadr sre))
                   (map rec (cddr sre))))
            ((/)
             (let ((res (plist->alist (sre-flatten-ranges (cdr sre)))))
               (if ci?
                   (cset-case-insensitive res)
                   res)))
            ((or)
             (fold cset-union (rec (cadr sre)) (map rec (cddr sre))))
            ((w/case)
             (lp (sre-alternate (cdr sre)) #f))
            ((w/nocase)
             (lp (sre-alternate (cdr sre)) #t))
            (else
             (error "not a valid sre char-set operator" sre)))))
     ((char? sre) (rec (list (string sre))))
     ((string? sre) (rec (list sre)))
     (else
      (let ((cell (assq sre sre-named-definitions)))
        (if cell
            (rec (cdr cell))
            (error "not a valid sre char-set" sre)))))))

;; another debugging utility
;; (define (cset->sre cset)
;;   (let lp ((ls cset) (chars '()) (ranges '()))
;;     (cond
;;      ((null? ls)
;;       (sre-alternate
;;        (append
;;         (if (pair? chars) (list (list (list->string chars))) '())
;;         (if (pair? ranges) (list (cons '/ (alist->plist ranges))) '()))))
;;      ((char? (car ls)) (lp (cdr ls) (cons (car ls) chars) ranges))
;;      (else (lp (cdr ls) chars (cons (car ls) ranges))))))

(define (cset-contains? cset ch)
  (find (lambda (x)
          (or (eqv? x ch)
              (and (pair? x) (char<=? (car x) ch) (char<=? ch (cdr x)))))
        cset))

(define (cset-range x)
  (if (char? x) (cons x x) x))

(define (char-ranges-overlap? a b)
  (if (pair? a)
      (if (pair? b)
          (or (and (char<=? (car a) (cdr b)) (char<=? (car b) (cdr a)))
              (and (char<=? (cdr b) (car a)) (char<=? (cdr a) (car b))))
          (and (char<=? (car a) b) (char<=? b (cdr a))))
      (if (pair? b)
          (char-ranges-overlap? b a)
          (eqv? a b))))

(define (char-ranges-union a b)
  (cons (if (char<=? (car a) (car b)) (car a) (car b))
        (if (char>=? (cdr a) (cdr b)) (cdr a) (cdr b))))

(define (cset-union a b)
  (cond ((null? b) a)
        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
         => (lambda (ls)
              (cset-union
               (cset-union (append (take-up-to a ls) (cdr ls))
                           (list (char-ranges-union (cset-range (car ls))
                                                    (cset-range (car b)))))
               (cdr b))))
        (else (cset-union (cons (car b) a) (cdr b)))))

(define (cset-difference a b)
  (cond ((null? b) a)
        ((not (car b)) (cset-difference a (cdr b)))
        ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
         => (lambda (ls)
              (apply
               (lambda (left1 left2 same right1 right2)
                 (let* ((a (append (take-up-to a ls) (cdr ls)))
                        (a (if left1 (cons left1 a) a))
                        (a (if left2 (cons left2 a) a))
                        (b (if right1 (cset-union b (list right1)) b))
                        (b (if right2 (cset-union b (list right2)) b)))
                   (cset-difference a b)))
               (intersect-char-ranges (cset-range (car ls))
                                      (cset-range (car b))))))
        (else (cset-difference a (cdr b)))))

(define (cset-intersection a b)
  (let intersect ((a a) (b b) (res '()))
    (cond ((null? b) res)
          ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
           => (lambda (ls)
                (apply
                 (lambda (left1 left2 same right1 right2)
                   (let* ((a (append (take-up-to a ls) (cdr ls)))
                          (a (if left1 (cons left1 a) a))
                          (a (if left2 (cons left2 a) a))
                          (b (if right1 (cset-union b (list right1)) b))
                          (b (if right2 (cset-union b (list right2)) b)))
                     (intersect a b (cset-union res (list same)))))
                 (intersect-char-ranges (cset-range (car ls))
                                        (cset-range (car b))))))
          (else (intersect a (cdr b) res)))))

(define (cset-complement a)
  (cset-difference (sre->cset *all-chars*) a))

(define (cset-case-insensitive a)
  (let lp ((ls a) (res '()))
    (cond ((null? ls) (reverse res))
          ((and (char? (car ls)) (char-alphabetic? (car ls)))
           (let ((c2 (char-altcase (car ls)))
                 (res (cons (car ls) res)))
             (lp (cdr ls) (if (cset-contains? res c2) res (cons c2 res)))))
          ((and (pair? (car ls))
                (char-alphabetic? (caar ls))
                (char-alphabetic? (cdar ls)))
           (lp (cdr ls)
               (cset-union (cset-union res (list (car ls)))
                           (list (cons (char-altcase (caar ls))
                                       (char-altcase (cdar ls)))))))
          (else (lp (cdr ls) (cset-union res (list (car ls))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Match and Replace Utilities

(define (irregex-fold/fast irx kons knil str . o)
  (if (not (string? str)) (error "irregex-fold: not a string" str))
  (if (not (procedure? kons)) (error "irregex-fold: not a procedure" kons))
  (let* ((irx (irregex irx))
         (matches (irregex-new-matches irx))
         (finish (or (and (pair? o) (car o)) (lambda (i acc) acc)))
         (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
         (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
                  (caddr o)
                  (string-length str))))
    (irregex-match-chunker-set! matches irregex-basic-string-chunker)
    (let lp ((i start) (acc knil))
      (if (>= i end)
          (finish i acc)
          (let ((m (irregex-search/matches
                    irx
                    irregex-basic-string-chunker
                    (list str i end)
                    i
                    matches)))
            (if (not m)
                (finish i acc)
                (let* ((end (%irregex-match-end-index m 0))
                       (acc (kons i m acc)))
                  (irregex-reset-matches! matches)
                  (lp end acc))))))))

(define (irregex-fold irx kons . args)
  (let ((kons2 (lambda (i m acc) (kons i (irregex-copy-matches m) acc))))
    (apply irregex-fold/fast irx kons2 args)))

(define (irregex-fold/chunked/fast irx kons knil cnk start . o)
  (let* ((irx (irregex irx))
         (matches (irregex-new-matches irx))
         (finish (or (and (pair? o) (car o)) (lambda (src i acc) acc)))
         (i (if (and (pair? o) (pair? (cdr o)))
                (cadr o)
                ((chunker-get-start cnk) start))))
    (irregex-match-chunker-set! matches cnk)
    (let lp ((start start) (i i) (acc knil))
      (if (not start)
          (finish start i acc)
          (let ((m (irregex-search/matches irx cnk start i matches)))
            (if (not m)
                (finish start i acc)
                (let* ((acc (kons start i m acc))
                       (end-src (%irregex-match-end-chunk m 0))
                       (end-index (%irregex-match-end-index m 0)))
                  (irregex-reset-matches! matches)
                  (lp end-src end-index acc))))))))

(define (irregex-fold/chunked irx kons . args)
  (let ((kons2 (lambda (s i m acc) (kons s i (irregex-copy-matches m) acc))))
    (apply irregex-fold/chunked/fast irx kons2 args)))

(define (irregex-replace irx str . o)
  (if (not (string? str)) (error "irregex-replace: not a string" str))
  (let ((m (irregex-search irx str)))
    (and
     m
     (string-cat-reverse
      (cons (substring str (%irregex-match-end-index m 0) (string-length str))
            (append (irregex-apply-match m o)
                    (list (substring str 0 (%irregex-match-start-index m 0)))
                    ))))))

(define (irregex-replace/all irx str . o)
  (if (not (string? str)) (error "irregex-replace/all: not a string" str))
  (irregex-fold/fast
   irx
   (lambda (i m acc)
     (let ((m-start (%irregex-match-start-index m 0)))
       (append (irregex-apply-match m o)
               (if (>= i m-start)
                   acc
                   (cons (substring str i m-start) acc)))))
   '()
   str
   (lambda (i acc)
     (let ((end (string-length str)))
       (string-cat-reverse (if (>= i end)
                               acc
                               (cons (substring str i end) acc)))))))

(define (irregex-apply-match m ls)
  (let lp ((ls ls) (res '()))
    (if (null? ls)
        res
        (cond
         ((integer? (car ls))
          (lp (cdr ls)
              (cons (or (irregex-match-substring m (car ls)) "") res)))
         ((procedure? (car ls))
          (lp (cdr ls) (cons ((car ls) m) res)))
         ((symbol? (car ls))
          (case (car ls)
            ((pre)
             (lp (cdr ls)
                 (cons (substring (car (%irregex-match-start-chunk m 0))
                                  0
                                  (%irregex-match-start-index m 0))
                       res)))
            ((post)
             (let ((str (car (%irregex-match-start-chunk m 0))))
               (lp (cdr ls)
                   (cons (substring str
                                    (%irregex-match-end-index m 0)
                                    (string-length str))
                         res))))
            (else
             (cond
              ((assq (car ls) (irregex-match-names m))
               => (lambda (x) (lp (cons (cdr x) (cdr ls)) res)))
              (else
               (error "unknown match replacement" (car ls)))))))
         (else
          (lp (cdr ls) (cons (car ls) res)))))))

(define (irregex-extract irx str . o)
  (if (not (string? str)) (error "irregex-extract: not a string" str))
  (apply irregex-fold/fast
         irx
         (lambda (i m a) (cons (irregex-match-substring m) a))
         '()
         str
         (lambda (i a) (reverse a))
         o))

(define (irregex-split irx str . o)
  (if (not (string? str)) (error "irregex-split: not a string" str))
  (let ((start (if (pair? o) (car o) 0))
        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
    (irregex-fold/fast
     irx
     (lambda (i m a)
       (if (= i (%irregex-match-start-index m 0))
           a
           (cons (substring str i (%irregex-match-start-index m 0)) a)))
     '()
     str
     (lambda (i a)
       (reverse (if (= i end) a (cons (substring str i end) a))))
     start
     end)))