Note: the patterns described in the doc.txt file are
slightly different than the patterns processed here.
The difference is in the form of the side-condition
expressions. Here they are procedures that accept
binding structures, instead of expressions. The
reduction (And other) macros do this transformation
before the pattern compiler is invoked.

(module matcher mzscheme
  (require (lib "")
           (lib "")
           (lib "")
           (lib ""))
  ;; lang = (listof nt)
  ;; nt = (make-nt sym (listof rhs))
  ;; rhs = (make-rhs single-pattern)
  ;; single-pattern = sexp
  (define-struct nt (name rhs) (make-inspector))
  (define-struct rhs (pattern) (make-inspector))
  ;; var = (make-var sym sexp)
  ;; patterns are sexps with `var's embedded
  ;; in them. It means to match the
  ;; embedded sexp and return that binding
  ;; bindings = (make-bindings (listof rib))
  ;; rib = (make-rib sym sexp)
  ;; if a rib has a pair, the first element of the pair should be treated as a prefix on the identifer
  (define-values (make-bindings bindings-table bindings?)
    (let () 
      (define-struct bindings (table) (make-inspector)) ;; for testing, add inspector
      (values (lambda (table)
                (unless (and (list? table)
                             (andmap rib? table))
                  (error 'make-bindings "expected <(listof rib)>, got ~e" table))
                (make-bindings table))
  (define-struct rib (name exp) (make-inspector)) ;; for testing, add inspector
  ;; repeat = (make-repeat compiled-pattern (listof rib))
  (define-struct repeat (pat empty-bindings) (make-inspector)) ;; inspector for tests below
  ;; compiled-pattern : exp (union #f none sym) -> (union #f (listof mtch))
  ;; mtch = (make-match bindings sexp[context w/none-inside for the hole] (union none sexp[hole]))
  ;; mtch is short for "match"
  (define-values (mtch-bindings mtch-context mtch-hole make-mtch mtch?)
    (let ()
      (define-struct mtch (bindings context hole) (make-inspector))
      (values mtch-bindings
              (lambda (a b c)
                (unless (bindings? a)
                  (error 'make-mtch "expected bindings for first agument, got ~e" a))
                (make-mtch a b c))
  ;; used to mean no context is available; also used as the "name" for an unnamed (ie, normal) hole
  (define none
    (let ()
      (define-struct none ())
  (define (none? x) (eq? x none))
  (define hole
    (let ()
      (define-struct hole ())
  ;; compiled-lang : (make-compiled-lang (listof nt)
  ;;                                     hash-table[sym -o> compiled-pattern]
  ;;                                     hash-table[sym -o> compiled-pattern]
  ;;                                     hash-table[sym -o> boolean])
  ;;                                     hash-table[sexp[pattern] -o> (cons compiled-pattern boolean)])
  ;; hole-info = (union #f none symbol)
  ;;               #f means we're not in a `in-hole' context
  ;;               none means we're looking for a normal hole
  ;;               symbol means we're looking for a named hole named by the symbol
  (define compiled-pattern (any/c (union false/c none? symbol?) . -> . (union false/c (listof mtch?))))
  (define-struct compiled-lang (lang ht across-ht has-hole-ht cache))
  ;; lookup-binding : bindings (union sym (cons sym sym)) [(-> any)] -> any
  (define lookup-binding 
    (opt-lambda (bindings
		 [fail (lambda () (error 'lookup-binding "didn't find ~e in ~e" sym bindings))])
      (let loop ([ribs (bindings-table bindings)])
          [(null? ribs) (fail)]
           (let ([rib (car ribs)])
             (if (equal? (rib-name rib) sym)
                 (rib-exp rib)
                 (loop (cdr ribs))))]))))
  ;; compile-language : lang -> compiled-lang
  (define (compile-language lang)
    (let* ([clang-ht (make-hash-table)]
           [across-ht (make-hash-table)]
           [has-hole-ht (build-has-hole-ht lang)]
           [cache (make-hash-table 'equal)]
           [clang (make-compiled-lang lang clang-ht across-ht has-hole-ht cache)]
            (lambda (ht lang prefix-cross?)
               (lambda (nt)
                  (lambda (rhs)
                    (let-values ([(compiled-pattern has-hole?) 
                                  (compile-pattern/cross? clang (rhs-pattern rhs) prefix-cross?)])
                       (nt-name nt)
                       (cons compiled-pattern
                             (hash-table-get ht (nt-name nt))))))
                  (nt-rhs nt)))
      (for-each (lambda (nt)
                  (hash-table-put! clang-ht (nt-name nt) null))
       (lambda (nt rhs)
         (when (has-underscore? nt)
           (error 'compile-language "cannot use underscore in nonterminal name, ~s" nt))))
      (let ([compatible-context-language
             (build-compatible-context-language clang-ht lang)])
        (for-each (lambda (nt)
                    (hash-table-put! across-ht (nt-name nt) null))
        (do-compilation clang-ht lang #t)
        (do-compilation across-ht compatible-context-language #f)
  ; build-has-hole-ht : (listof nt) -> hash-table[symbol -o> boolean]
  ; produces a map of nonterminal -> whether that nonterminal could produce a hole
  (define (build-has-hole-ht lang)
    (let ([has-hole-ht (make-hash-table)])
       (lambda (nt) (hash-table-put! has-hole-ht (nt-name nt) #t))
  ;; build-compatible-context-language : lang -> lang
  (define (build-compatible-context-language clang-ht lang)
      (lambda (nt1)
         (lambda (nt2)
           (let ([compat-nt (build-compatible-contexts/nt clang-ht (nt-name nt1) nt2)])
             (if (eq? (nt-name nt1) (nt-name nt2))
                 (make-nt (nt-name compat-nt)
                           (make-rhs 'hole)
                           (nt-rhs compat-nt)))
  ;; build-compatible-contexts : clang-ht prefix nt -> nt
  ;; constructs the compatible closure evaluation context from nt.
  (define (build-compatible-contexts/nt clang-ht prefix nt)
     (symbol-append prefix '- (nt-name nt))
     (apply append
             (lambda (rhs)
               (let-values ([(maker count) (build-compatible-context-maker clang-ht
                                                                           (rhs-pattern rhs)
                 (let loop ([i count])
                     [(zero? i) null]
                     [else (let ([nts (build-across-nts (nt-name nt) count (- i 1))])
                             (cons (make-rhs (maker (box nts)))
                                   (loop (- i 1))))]))))
             (nt-rhs nt)))))
  (define (symbol-append . args)
    (string->symbol (apply string-append (map symbol->string args))))
  ;; build-across-nts : symbol number number -> (listof pattern)
  (define (build-across-nts nt count i)
    (let loop ([j count])
        [(zero? j) null]
         (cons (= i (- j 1)) 
               (loop (- j 1)))])))
  ;; build-compatible-context-maker : symbol pattern -> (values ((box (listof pattern)) -> pattern) number)
  ;; when the result function is applied, it takes each element
  ;; of the of the boxed list and plugs them into the places where
  ;; the nt corresponding from this rhs appeared in the original pattern.
  ;; The number result is the number of times that the nt appeared in the pattern.
  (define (build-compatible-context-maker clang-ht pattern prefix)
    (let ([count 0])
       (let loop ([pattern pattern])
         (match pattern
           [`any (lambda (l) 'any)]
           [`number (lambda (l) 'number)]
           [`string (lambda (l) 'string)]
           [`variable (lambda (l) 'variable)] 
           [`(variable-except ,@(vars ...)) (lambda (l) pattern)]
           [`hole  (lambda (l) 'hole)]
           [`(hole ,(? symbol? hole-name)) (lambda (l) `(hole ,hole-name))]
           [(? string?) (lambda (l) pattern)]
           [(? symbol?) 
              [(hash-table-get clang-ht pattern (lambda () #f))
               (set! count (+ count 1))
               (lambda (l)
                 (let ([fst (car (unbox l))])
                   (set-box! l (cdr (unbox l)))
                   (if fst
                       `(cross ,(symbol-append prefix '- pattern))
               (lambda (l) pattern)])]
           [`(name ,name ,pat)
            (let ([patf (loop pat)])
              (lambda (l)
                `(name ,name ,(patf l))))]
           [`(in-hole ,context ,contractum)
            (let ([match-context (loop context)]
                  [match-contractum (loop contractum)])
              (lambda (l)
                `(in-hole ,(match-context l)
                          ,(match-contractum l))))]
           [`(in-named-hole ,hole-name ,context ,contractum)
            (let ([match-context (loop context)]
                  [match-contractum (loop contractum)])
              (lambda (l)
                `(in-named-hole ,hole-name
                                ,(match-context l)
                                ,(match-contractum l))))]
           [`(side-condition ,pat ,condition)
            (let ([patf (loop pat)])
              (lambda (l)
                `(side-condition ,(patf l) ,condition)))]
           [(? list?)
            (let ([fs (map loop pattern)])
              (lambda (l)
                (map (lambda (f) (f l)) fs)))]
            (lambda (l) pattern)]))
  ;; match-pattern : compiled-pattern exp -> (union #f (listof bindings))
  (define (match-pattern compiled-pattern exp)
    (let ([results (compiled-pattern exp #f)])
      (and results
           (let ([filtered (filter-multiples results)])
             (and (not (null? filtered))
  ;; filter-multiples : (listof mtch) -> (listof mtch)
  (define (filter-multiples matches)
    (let loop ([matches matches]
               [acc null])
        [(null? matches) acc]
         (let ([merged (merge-multiples/remove (car matches))])
           (if merged
               (loop (cdr matches) (cons merged acc))
               (loop (cdr matches) acc)))])))
  ;; merge-multiples/remove : bindings -> (union #f bindings)
  ;; returns #f if all duplicate bindings don't bind the same thing
  ;; returns a new bindings
  (define (merge-multiples/remove match)
    (let/ec fail
      (let ([ht (make-hash-table 'equal)]
            [ribs (bindings-table (mtch-bindings match))])
         (lambda (rib)
           (let/ec new
             (let ([name (rib-name rib)]
                   [exp (rib-exp rib)])
               (let ([previous-exp
                       (lambda ()
                         (hash-table-put! ht name exp)
                         (new (void))))])
                 (unless (equal? exp previous-exp)
                   (fail #f))))))
         (make-bindings (hash-table-map ht make-rib))
         (mtch-context match)
         (mtch-hole match)))))
  (define underscore-allowed '(any number string variable))

  ;; compile-pattern : compiled-lang pattern -> compiled-pattern
  (define compile-pattern
    (opt-lambda (clang pattern)
      (let-values ([(pattern has-hole?) (compile-pattern/cross? clang pattern #t)])
  ;; compile-pattern : compiled-lang pattern boolean -> (values compiled-pattern boolean)
  (define (compile-pattern/cross? clang pattern prefix-cross?)
    (define clang-ht (compiled-lang-ht clang))
    (define has-hole-ht (compiled-lang-has-hole-ht clang))
    (define across-ht (compiled-lang-across-ht clang))
    (define compiled-pattern-cache (compiled-lang-cache clang))
    (define (compile-pattern/cache pattern)
      (let ([compiled-cache (hash-table-get
                             (lambda ()
                               (let-values ([(compiled-pattern has-hole?)
                                             (true-compile-pattern pattern)])
                                 (let ([val (cons (memoize compiled-pattern has-hole?) has-hole?)])
                                   (hash-table-put! compiled-pattern-cache pattern val)
        (values (car compiled-cache) (cdr compiled-cache))))
    ;; consult-compiled-pattern-cache : sexp[pattern] (-> compiled-pattern) -> compiled-pattern
    (define (consult-compiled-pattern-cache pattern calc)
       (lambda ()
         (let ([res (calc)])
           (hash-table-put! compiled-pattern-cache pattern res)
    (define (true-compile-pattern pattern)
      (match pattern
           (lambda (exp hole-info) (list (make-mtch (make-bindings null) exp none)))
           (lambda (exp hole-info) (and (number? exp) (list (make-mtch (make-bindings null) exp none))))
           (lambda (exp hole-info) (and (string? exp) (list (make-mtch (make-bindings null) exp none))))
           (lambda (exp hole-info)
             (and (symbol? exp) (list (make-mtch (make-bindings null) exp none))))
        [`(variable-except ,@(vars ...))
           (lambda (exp hole-info)
             (and (symbol? exp)
                  (not (memq exp vars))
                  (list (make-mtch (make-bindings null) exp none))))
        [`hole (values (match-hole none) #t)]
        [`(hole ,hole-id) (values (match-hole hole-id) #t)]
        [(? string?) 
          (lambda (exp hole-info)
            (and (string? exp)
                 (string=? exp pattern)
                 (list (make-mtch (make-bindings null) exp none))))
        [(? symbol?)
           [(hash-table-maps? clang-ht pattern)
             (lambda (exp hole-info)
               (match-nt clang-ht pattern exp hole-info))
             (hash-table-get has-hole-ht pattern))]
           [(has-underscore? pattern)
            (let ([before (split-underscore pattern)])
              (unless (or (hash-table-maps? clang-ht before)
                          (memq before underscore-allowed))
                (error 'compile-pattern "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" 
              (compile-pattern/cache `(name ,pattern ,before)))]
             (lambda (exp hole-info) (and (eq? exp pattern) (list (make-mtch (make-bindings null) exp none))))
        [`(cross ,(? symbol? pre-id))
          (let ([id (if prefix-cross?
                        (symbol-append pre-id '- pre-id)
              [(hash-table-get across-ht id (lambda () #f))
                (lambda (exp hole-info)
                  (match-nt across-ht id exp hole-info))
               (error 'compile-pattern "unknown cross reference ~a" id)]))]
        [`(name ,name ,pat)
          (let-values ([(match-pat has-hole?) (compile-pattern/cache pat)])
             (lambda (exp hole-info)
               (let ([matches (match-pat exp hole-info)])
                 (and matches 
                      (map (lambda (match)
                              (make-bindings (cons (make-rib name (mtch-context match))
                                                   (bindings-table (mtch-bindings match))))
                              (mtch-context match)
                              (mtch-hole match)))
        [`(in-hole ,context ,contractum) 
          (let-values ([(match-context ctxt-has-hole?) (compile-pattern/cache context)]
                       [(match-contractum contractum-has-hole?) (compile-pattern/cache contractum)])
             (match-in-hole context contractum exp match-context match-contractum none)
             (or ctxt-has-hole? contractum-has-hole?)))]
        [`(in-named-hole ,hole-id ,context ,contractum) 
          (let-values ([(match-context ctxt-has-hole?) (compile-pattern/cache context)]
                       [(match-contractum contractum-has-hole?) (compile-pattern/cache contractum)])
             (match-in-hole context contractum exp match-context match-contractum hole-id)
             (or ctxt-has-hole? contractum-has-hole?)))]
        [`(side-condition ,pat ,condition)
          (let-values ([(match-pat has-hole?) (compile-pattern/cache pat)])
             (lambda (exp hole-info)
               (let ([matches (match-pat exp hole-info)])
                 (and matches
                      (let ([filtered (filter (λ (m) (condition (mtch-bindings m))) matches)])
                        (if (null? filtered)
        [(? list?)
         (let-values ([(rewritten has-hole?) (rewrite-ellipses pattern compile-pattern/cache)])
            (lambda (exp hole-info)
              (match-list rewritten exp hole-info))
        ;; an already comiled pattern
        [(? procedure?)
          (lambda (exp hole-info)
            (and (eqv? pattern exp)
                 (list (make-mtch (make-bindings null) exp none))))
    (compile-pattern/cache pattern))

  ;; split-underscore : symbol -> symbol
  ;; returns the text before the underscore in a symbol (as a symbol)
  ;; raise an error if there is more than one underscore in the input
  (define (split-underscore sym)
      (let loop ([chars (string->list (symbol->string sym))])
          [(null? chars) (error 'split-underscore "bad")]
           (let ([c (car chars)])
               [(char=? c #\_)
                (when (memq #\_ (cdr chars))
                  (error 'compile-pattern "found a symbol with multiple underscores: ~s" sym))
               [else (cons c (loop (cdr chars)))]))])))))
  ;; has-underscore? : symbol -> boolean
  (define (has-underscore? sym)
    (memq #\_ (string->list (symbol->string sym))))
  (define (memoize f needs-all-args?)
    (if needs-all-args?
        (memoize2 f)
        (memoize1 f)))
  ; memoize1 : (x y -> w) -> x y -> w
  ; memoizes a function of two arguments under the assumption
  ; that the function is constant w.r.t the second
  (define (memoize1 f) (memoize/key f (lambda (x y) x) nohole))
  (define (memoize2 f) (memoize/key f cons w/hole))
  (define (memoize/key f key-fn statsbox)
    (let ([ht (make-hash-table 'equal)]
	  [entries 0])
      (lambda (x y)
        (set-cache-stats-hits! statsbox (add1 (cache-stats-hits statsbox)))
        (let* ([key (key-fn x y)]
                (lambda ()
                  (set! entries (+ entries 1))
                  (set-cache-stats-hits! statsbox (sub1 (cache-stats-hits statsbox)))
                  (set-cache-stats-misses! statsbox (add1 (cache-stats-misses statsbox)))
                  (let ([res (f x y)])
                    (hash-table-put! ht key res)
          (unless (< entries 10000)
            (set! entries 0)
            (set! ht (make-hash-table 'equal)))
          (hash-table-get ht key compute/cache)))))
  (define-struct cache-stats (name misses hits))
  (define (new-cache-stats name) (make-cache-stats name 0 0))

  (define w/hole (new-cache-stats "hole"))
  (define nohole (new-cache-stats "no-hole"))
  (define (print-stats)
    (let ((stats (list w/hole nohole)))
       (lambda (s) 
         (when (> (+ (cache-stats-hits s) (cache-stats-misses s)) 0)
           (printf "~a has ~a hits, ~a misses (~a)\n" 
                   (cache-stats-name s)
                   (cache-stats-hits s)
                   (cache-stats-misses s)
                   (* 100 (/ (cache-stats-hits s)
                             (+ (cache-stats-hits s) (cache-stats-misses s)))))))
      (let ((overall-hits (apply + (map cache-stats-hits stats)))
            (overall-miss (apply + (map cache-stats-misses stats))))
        (printf "---\nOverall hits: ~a\n" overall-hits)
        (printf "\nOverall misses: ~a\n" overall-miss)
        (when (> (+ overall-hits overall-miss) 0)
          (printf "\nOverall rate: ~a\n" (* 100 (/ overall-hits (+ overall-hits overall-miss))))))))

  ;; match-hole : (union #f symbol) -> compiled-pattern
  (define (match-hole hole-id)
    (lambda (exp hole-info)
      (and hole-info
           (eq? hole-id hole-info)
           (list (make-mtch (make-bindings '())
  ;; match-in-hole : sexp sexp sexp compiled-pattern compiled-pattern hole-info -> compiled-pattern
  (define (match-in-hole context contractum exp match-context match-contractum hole-info)
    (lambda (exp old-hole-info)
      (let ([mtches (match-context exp hole-info)])
        (and mtches
             (let loop ([mtches mtches]
                        [acc null])
                 [(null? mtches) acc]
                  (let* ([mtch (car mtches)]
                         [bindings (mtch-bindings mtch)]
                         [hole-exp (mtch-hole mtch)]
                         [contractum-mtches (match-contractum hole-exp old-hole-info)])
                    (if contractum-mtches
                        (let i-loop ([contractum-mtches contractum-mtches]
                                     [acc acc])
                            [(null? contractum-mtches) (loop (cdr mtches) acc)]
                            [else (let* ([contractum-mtch (car contractum-mtches)]
                                         [contractum-bindings (mtch-bindings contractum-mtch)])
                                     (cdr contractum-mtches)
                                      (make-mtch (make-bindings
                                                  (append (bindings-table contractum-bindings)
                                                          (bindings-table bindings)))
                                                 (plug (mtch-context mtch) (mtch-context contractum-mtch))
                                                 (mtch-hole contractum-mtch))
                        (loop (cdr mtches) acc)))]))))))
  (define (plug exp hole-stuff)
    (let loop ([exp exp])
        [(pair? exp) (cons (loop (car exp)) (loop (cdr exp)))]
        [(eq? exp hole) hole-stuff]
        [else exp])))
  ;; match-list : (listof (union repeat compiled-pattern)) sexp hole-info -> (union #f (listof bindings))
  (define (match-list patterns exp hole-info)
    (let (;; raw-match : (listof (listof (listof mtch)))
          [raw-match (match-list/raw patterns exp hole-info)])
      (and (not (null? raw-match))
           (let* (;; combined-matches : (listof (listof mtch))
                  ;; a list of complete possibilities for matches
                  ;; (analagous to multiple matches of a single non-terminal)
                  [combined-matches (map combine-matches raw-match)]
                  ;; flattened-matches : (union #f (listof bindings))
                  [flattened-matches (if (null? combined-matches)
                                         (apply append combined-matches))])
  ;; match-list/raw : (listof (union repeat compiled-pattern))
  ;;                  sexp
  ;;                  hole-info
  ;;               -> (listof (listof (listof mtch)))
  ;; the result is the raw accumulation of the matches for each subpattern, as follows:
  ;;  (listof (listof (listof mtch)))
  ;;  \       \       \-------------/  a match for one position in the list (failures don't show up)
  ;;   \       \-------------------/   one element for each position in the pattern list
  ;;    \-------------------------/    one element for different expansions of the ellipses
  ;; the failures to match are just removed from the outer list before this function finishes
  ;; via the `fail' argument to `loop'.
  (define (match-list/raw patterns exp hole-info)
    (let/ec k
      (let loop ([patterns patterns]
                 [exp exp]
                 ;; fail : -> alpha
                 ;; causes one possible expansion of ellipses to fail
                 ;; initially there is only one possible expansion, so
                 ;; everything fails.
                 [fail (lambda () (k null))])
          [(pair? patterns)
           (let ([fst-pat (car patterns)])
               [(repeat? fst-pat)
                (if (or (null? exp) (pair? exp))
                    (let ([r-pat (repeat-pat fst-pat)]
                          [r-mt (make-mtch (make-bindings (repeat-empty-bindings fst-pat))
                       (cons (let/ec k
                               (let ([mt-fail (lambda () (k null))])
                                 (map (lambda (pat-ele) (cons (list r-mt) pat-ele))
                                      (loop (cdr patterns) exp mt-fail))))
                             (let r-loop ([exp exp]
                                          ;; past-matches is in reverse order
                                          ;; it gets reversed before put into final list
                                          [past-matches (list r-mt)])
                                 [(pair? exp)
                                  (let* ([fst (car exp)]
                                         [m (r-pat fst hole-info)])
                                    (if m
                                        (let* ([combined-matches (collapse-single-multiples m past-matches)]
                                               [reversed (reverse-multiples combined-matches)])
                                           (let/ec fail-k
                                             (map (lambda (x) (cons reversed x))
                                                  (loop (cdr patterns) 
                                                        (cdr exp)
                                                        (lambda () (fail-k null)))))
                                           (r-loop (cdr exp) combined-matches)))
                                        (list null)))]
                                 ;; what about dotted pairs?
                                 [else (list null)])))))
                  [(pair? exp)
                   (let* ([fst-exp (car exp)]
                          [match (fst-pat fst-exp hole-info)])
                     (if match
                         (let ([exp-match (map (λ (mtch) (make-mtch (mtch-bindings mtch)
                                                                    (list (mtch-context mtch))
                                                                    (mtch-hole mtch)))
                           (map (lambda (x) (cons exp-match x))
                                (loop (cdr patterns) (cdr exp) fail)))
           (if (null? exp)
               (list null)
  ;; collapse-single-multiples : (listof mtch) (listof mtch[to-lists]) -> (listof mtch[to-lists])
  (define (collapse-single-multiples bindingss multiple-bindingss)
    (apply append 
            (lambda (multiple-match)
              (let ([multiple-bindings (mtch-bindings multiple-match)])
                 (lambda (single-match)
                   (let ([single-bindings (mtch-bindings single-match)])
                     (let ([ht (make-hash-table 'equal)])
                        (lambda (multiple-rib)
                          (hash-table-put! ht (rib-name multiple-rib) (rib-exp multiple-rib)))
                        (bindings-table multiple-bindings))
                        (lambda (single-rib)
                          (let* ([key (rib-name single-rib)]
                                 [rst (hash-table-get ht key (lambda () null))])
                            (hash-table-put! ht key (cons (rib-exp single-rib) rst))))
                        (bindings-table single-bindings))
                       (make-mtch (make-bindings (hash-table-map ht make-rib))
                                  (cons (mtch-context single-match)
                                        (mtch-context multiple-match))
                                  (pick-hole (mtch-hole single-match)
                                             (mtch-hole multiple-match))))))
  ;; pick-hole : (union none sexp) (union none sexp) -> (union none sexp)
  (define (pick-hole s1 s2)
      [(eq? none s1) s2]
      [(eq? none s2) s1]
      [(error ' "found two holes in list pattern ~s ~s" s1 s2)]))
  ;; reverse-multiples : (listof mtch[to-lists]) -> (listof mtch[to-lists])
  ;; reverses the rhs of each rib in the bindings and reverses the context.
  (define (reverse-multiples matches)
    (map (lambda (match)
           (let ([bindings (mtch-bindings match)])
               (map (lambda (rib)
                      (make-rib (rib-name rib)
                                (reverse (rib-exp rib))))
                    (bindings-table bindings)))
              (reverse (mtch-context match))
              (mtch-hole match))))
  ;; match-nt : hash-table[from compiled-lang] sym exp hole-info -> (union #f (listof bindings))
  (define (match-nt clang-ht nt term hole-info)
    (let ([compiled-rhss (hash-table-get clang-ht nt)])
      (let loop ([rhss compiled-rhss]
                 [anss null])
          [(null? rhss) (if (null? anss) #f (apply append anss))]
           (let ([mth (remove-bindings/filter ((car rhss) term hole-info))])
             (if mth
                 (loop (cdr rhss) (cons mth anss))
                 (loop (cdr rhss) anss)))]))))
  ;; remove-bindings/filter : (union #f (listof mtch)) -> (union #f (listof mtch))
  (define (remove-bindings/filter matches)
    (and matches
         (let ([filtered (filter-multiples matches)])
           (and (not (null? filtered))
                (map (λ (match)
                       (make-mtch (make-bindings '())
                                  (mtch-context match)
                                  (mtch-hole match)))
  ;; rewrite-ellipses : (listof pattern)
  ;;                    (pattern -> (values compiled-pattern boolean))
  ;;                 -> (values (listof (union repeat compiled-pattern)) boolean)
  ;; moves the ellipses out of the list and produces repeat structures
  (define (rewrite-ellipses pattern compile)
    (let loop ([exp-eles pattern]
               [fst dummy])
        [(null? exp-eles)
         (if (eq? fst dummy)
             (values empty #f)
             (let-values ([(compiled has-hole?) (compile fst)])
               (values (list compiled) has-hole?)))]
         (let ([exp-ele (car exp-eles)])
             [(eq? '... exp-ele)
              (when (eq? fst dummy)
                (error 'match-pattern "bad ellipses placement: ~s" pattern))
              (let-values ([(compiled has-hole?) (compile fst)]
                           [(rest rest-has-hole?) (loop (cdr exp-eles) dummy)])
                 (cons (make-repeat compiled (extract-empty-bindings fst)) rest)
                 (or has-hole? rest-has-hole?)))]
             [(eq? fst dummy)
              (loop (cdr exp-eles) exp-ele)]
              (let-values ([(compiled has-hole?) (compile fst)]
                           [(rest rest-has-hole?) (loop (cdr exp-eles) exp-ele)])
                 (cons compiled rest)
                 (or has-hole? rest-has-hole?)))]))])))
  (define dummy (box 0))
  ;; extract-empty-bindings : pattern -> (listof rib)
  (define (extract-empty-bindings pattern)
    (let loop ([pattern pattern]
               [ribs null])
      (match pattern
        [`any ribs]
        [`number ribs] 
        [`variable ribs] 
        [`(variable-except ,@(vars ...)) ribs]

        [`hole (error 'match-pattern "cannot have a hole inside an ellipses")]
        [(? symbol?) 
           [(has-underscore? pattern)
            (let ([before (split-underscore pattern)])
              (loop `(name ,pattern ,before) ribs))]
           [else ribs])]
        [`(name ,name ,pat) (loop pat (cons (make-rib name '()) ribs))]
        [`(in-hole ,context ,contractum) (loop context (loop contractum ribs))]
        [`(in-named-hole ,hole-name ,context ,contractum) (loop context (loop contractum ribs))]
        [`(side-condition ,pat ,test) (loop pat ribs)]
        [(? list?)
         (let-values ([(rewritten has-hole?) (rewrite-ellipses pattern (lambda (x) (values x #f)))])
           (let i-loop ([r-exps rewritten]
                        [ribs ribs])
               [(null? r-exps) ribs]
               [else (let ([r-exp (car r-exps)])
                         [(repeat? r-exp) 
                           (cdr r-exps)
                           (append (repeat-empty-bindings r-exp) ribs))]
                           (cdr r-exps)
                           (loop (car r-exps) ribs))]))])))]
        [else ribs])))
  ;; combine-matches : (listof (listof mtch)) -> (listof mtch)
  ;; input is the list of bindings corresonding to a piecewise match
  ;; of a list. produces all of the combinations of complete matches
  (define (combine-matches matchess)
    (let loop ([matchess matchess])
        [(null? matchess) (list (make-mtch (make-bindings null) '() none))]
        [else (combine-pair (car matchess) (loop (cdr matchess)))])))
  ;; combine-pair : (listof mtch) (listof mtch) -> (listof mtch)
  (define (combine-pair fst snd)
    (let ([mtchs null])
       (lambda (mtch1)
          (lambda (mtch2)
            (set! mtchs (cons (make-mtch 
                               (make-bindings (append (bindings-table (mtch-bindings mtch1))
                                                      (bindings-table (mtch-bindings mtch2))))
                               (append (mtch-context mtch1) (mtch-context mtch2))
                               (pick-hole (mtch-hole mtch1) 
                                          (mtch-hole mtch2)))

  (define (hash-table-maps? ht key)
    (let/ec k
      (hash-table-get ht key (lambda () (k #f)))
   (match-pattern (compiled-pattern any/c . -> . (union false/c (listof mtch?))))
   (compile-pattern (compiled-lang? any/c . -> . compiled-pattern))
   (make-bindings ((listof rib?) . -> . bindings?))
   (bindings-table (bindings? . -> . (listof rib?)))
   (bindings? (any/c . -> . boolean?))
   (mtch? (any/c . -> . boolean?))
   (make-mtch (bindings? any/c any/c . -> . mtch?))
   (mtch-bindings (mtch? . -> . bindings?))
   (mtch-context (mtch? . -> . any/c))
   (mtch-hole (mtch? . -> . (union none? any/c)))
   (make-rib (symbol? any/c . -> . rib?))
   (rib? (any/c . -> . boolean?))
   (rib-name (rib? . -> . symbol?))
   (rib-exp (rib? . -> . any/c)))
  (provide (struct nt (name rhs))
           (struct rhs (pattern))
           (struct compiled-lang (lang ht across-ht has-hole-ht cache))
           none? none