updates to syntax/parse/experimental/template

- changed substitute to use closure-compilation
- added stress/perf test for templates
- updated minimatch with vector patterns
- split substitute into separate file, minimize dependencies
- do ellipsis optimization dynamically
- validate guides: check var indexes

collects/syntax/parse/experimental/private/substitute.rkt

@@ -0,0 +1,297 @@
+#lang racket/base
+(require syntax/parse/private/minimatch
+         racket/private/stx) ;; syntax/stx
+(provide translate
+         error/not-stx)
+
+#|
+;; Doesn't seem to make much difference.
+(require (rename-in racket/unsafe/ops
+                    [unsafe-vector-ref vector-ref]
+                    [unsafe-vector-set! vector-set!]
+                    [unsafe-car car]
+                    [unsafe-cdr cdr]))
+|#
+
+;; ============================================================
+
+#|
+A Guide (G) is one of:
+  - '_
+  - positive-exact-integer  ;; represents depth=0 pvar ref or metafun ref
+  - negative-exact-integer  ;; represents depth>0 pvar ref (within ellipsis)
+  - (cons G G)
+  - (vector 'vector G)
+  - (vector 'struct G)
+  - (vector 'box G)
+  - (vector 'dots HG (vector-of integer) nat G)
+  - (vector 'app HG G)
+  - (vector 'escaped G)
+  - (vector 'orelse G (vector-of integer) G)
+  - (vector 'metafun integer G)
+
+A HeadGuide (HG) is one of:
+  - G
+  - (vector 'app-opt G (vector-of integer))
+  - (vector 'splice G)
+|#
+
+(define (head-guide? x)
+  (match x
+    [(vector 'app-opt g vars) #t]
+    [(vector 'splice g) #t]
+    [_ #f]))
+
+;; ============================================================
+
+;; A translated-template is (vector loop-env -> syntax)
+;; A loop-env is either a vector of values or a single value,
+;; depending on lenv-mode of enclosing ellipsis ('dots) form.
+
+(define (translate stx g env-length)
+  (let ([f (translate-g stx stx g env-length 0)])
+    (lambda (env lenv)
+      (unless (>= (vector-length env) env-length)
+        (error 'template "internal error: environment too short"))
+      (f env lenv))))
+
+;; lenv-mode is one of
+;;  - 'one ;; lenv is single value; address as -1
+;;  - nat  ;; lenv is vector; address as (- -1 index); 0 means no loop env
+
+(define (translate-g stx0 stx g env-length lenv-mode)
+  (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
+  (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
+  (define (get index env lenv) (get-var index env lenv lenv-mode))
+  (match g
+    ['_ (lambda (env lenv) stx)]
+    [(? exact-integer? index)
+     (check-var index env-length lenv-mode)
+     (lambda (env lenv) (check-stx stx (get index env lenv)))]
+    [(cons g1 g2)
+     (let ([f1 (loop (stx-car stx) g1)]
+           [f2 (loop (stx-cdr stx) g2)])
+       (cond [(syntax? stx)
+              (lambda (env lenv)
+                (restx stx (cons (f1 env lenv) (f2 env lenv))))]
+             [(eq? g1 '_)
+              (let ([c1 (stx-car stx)])
+                (lambda (env lenv)
+                  (cons c1 (f2 env lenv))))]
+             [(eq? g2 '_)
+              (let ([c2 (stx-cdr stx)])
+                (lambda (env lenv)
+                  (cons (f1 env lenv) c2)))]
+             [else
+              (lambda (env lenv)
+                (cons (f1 env lenv) (f2 env lenv)))]))]
+    [(vector 'dots ghead henv nesting gtail)
+     (let* ([lenv*-len (vector-length henv)]
+            [ghead-is-hg? (head-guide? ghead)]
+            [ftail (loop (stx-drop (add1 nesting) stx) gtail)])
+       (for ([var (in-vector henv)])
+         (check-var var env-length lenv-mode))
+       (cond [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?) (equal? ghead '-1))
+              ;; template was just (pvar ... . T)
+              (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)])
+                (lambda (env lenv)
+                  (let ([lenv* (get (vector-ref henv 0) env lenv)])
+                    (restx stx (append lenv* (ftail env lenv))))))]
+             [(and (= lenv*-len 1) (= nesting 1) (not ghead-is-hg?))
+              (let ([fhead (translate-g stx0 (stx-car stx) ghead env-length 'one)])
+                (lambda (env lenv)
+                  (restx stx
+                         (let dotsloop ([lenv* (get (vector-ref henv 0) env lenv)])
+                           (if (null? lenv*)
+                               (ftail env lenv)
+                               (cons (fhead env (car lenv*))
+                                     (dotsloop (cdr lenv*))))))))]
+             [else
+              (let ([fhead (if ghead-is-hg?
+                               (translate-hg stx0 (stx-car stx) ghead env-length lenv*-len)
+                               (translate-g stx0 (stx-car stx) ghead env-length lenv*-len))])
+                (lambda (env lenv)
+                  (define (nestloop lenv* nesting)
+                    (cond [(zero? nesting)
+                           (fhead env lenv*)]
+                          [else
+                           (check-lenv stx lenv*)
+                           (let ([len0 (length (vector-ref lenv* 0))])
+                             (let ([lenv** (make-vector (vector-length lenv*))])
+                               (let dotsloop ([len0 len0])
+                                 (if (zero? len0)
+                                     null
+                                     (begin (vector-car/cdr! lenv** lenv*)
+                                            (cons (nestloop lenv** (sub1 nesting))
+                                                  (dotsloop (sub1 len0))))))))]))
+                  (let ([head-results
+                         ;; if ghead-is-hg?, is (listof^(nesting+1) stx) -- extra listof for loop-h
+                         ;; otherwise, is (listof^nesting stx)
+                         (nestloop (vector-map (lambda (index) (get index env lenv)) henv)
+                                   nesting)]
+                        [tail-result (ftail env lenv)])
+                    (restx stx
+                           (nested-append head-results
+                                          (if ghead-is-hg? nesting (sub1 nesting))
+                                          tail-result)))))]))]
+    [(vector 'app ghead gtail)
+     (let ([fhead (loop-h (stx-car stx) ghead)]
+           [ftail (loop (stx-cdr stx) gtail)])
+       (lambda (env lenv)
+         (restx stx (append (fhead env lenv) (ftail env lenv)))))]
+    [(vector 'escaped g1)
+     (loop (stx-cadr stx) g1)]
+    [(vector 'orelse g1 drivers1 g2)
+     (let ([f1 (loop (stx-cadr stx) g1)]
+           [f2 (loop (stx-caddr stx) g2)])
+       (for ([var (in-vector drivers1)])
+         (check-var var env-length lenv-mode))
+       (lambda (env lenv)
+         (if (for/and ([index (in-vector drivers1)]) (get index env lenv))
+             (f1 env lenv)
+             (f2 env lenv))))]
+    [(vector 'metafun index g1)
+     (let ([f1 (loop (stx-cdr stx) g1)])
+       (check-var index env-length lenv-mode)
+       (lambda (env lenv)
+         (let ([v (restx stx (cons (stx-car stx) (f1 env lenv)))]
+               [mark (make-syntax-introducer)]
+               [old-mark (current-template-metafunction-introducer)]
+               [mf (get index env lenv)])
+           (parameterize ((current-template-metafunction-introducer mark))
+             (let ([r (mf (mark (old-mark v)))])
+               (unless (syntax? r)
+                 (raise-syntax-error 'template "result of metafunction was not syntax" stx))
+               (restx stx (old-mark (mark r))))))))]
+    [(vector 'vector g1)
+     (let ([f1 (loop (vector->list (syntax-e stx)) g1)])
+       (lambda (env lenv)
+         (restx stx (list->vector (f1 env lenv)))))]
+    [(vector 'struct g1)
+     (let ([f1 (loop (cdr (vector->list (struct->vector (syntax-e stx)))) g1)]
+           [key (prefab-struct-key (syntax-e stx))])
+       (lambda (env lenv)
+         (restx stx (apply make-prefab-struct key (f1 env lenv)))))]
+    [(vector 'box g1)
+     (let ([f1 (loop (unbox (syntax-e stx)) g1)])
+       (lambda (env lenv)
+         (restx stx (box (f1 env lenv)))))]))
+
+(define (translate-hg stx0 stx hg env-length lenv-mode)
+  (define (loop stx g) (translate-g stx0 stx g env-length lenv-mode))
+  (define (loop-h stx hg) (translate-hg stx0 stx hg env-length lenv-mode))
+  (define (get index env lenv) (get-var index env lenv lenv-mode))
+  (match hg
+    [(vector 'app-opt g1 drivers1)
+     (let ([f1 (loop (stx-cadr stx) g1)])
+       (for ([var (in-vector drivers1)])
+         (check-var var env-length lenv-mode))
+       (lambda (env lenv)
+         (if (for/and ([index (in-vector drivers1)]) (get index env lenv))
+             (list (f1 env lenv))
+             null)))]
+    [(vector 'splice g1)
+     (let ([f1 (loop (stx-cdr stx) g1)])
+       (lambda (env lenv)
+         (let* ([v (f1 env lenv)]
+                [v* (stx->list v)])
+           (unless v*
+             (raise-syntax-error 'template
+                                 "splicing template did not produce a syntax list"
+                                 stx))
+           v*)))]
+    [else
+     (let ([f (loop stx hg)])
+       (lambda (env lenv)
+         (list (f env lenv))))]))
+
+(define (get-var index env lenv lenv-mode)
+  (cond [(positive? index)
+         (vector-ref env (sub1 index))]
+        [(negative? index)
+         (case lenv-mode
+           ((one) lenv)
+           (else (vector-ref lenv (- -1 index))))]))
+
+(define (check-var index env-length lenv-mode)
+  (cond [(positive? index)
+         (unless (< (sub1 index) env-length)
+           (error/bad-index index))]
+        [(negative? index)
+         (unless (< (- -1 index)
+                    (case lenv-mode
+                      ((one) 1)
+                      (else lenv-mode)))
+           (error/bad-index))]))
+
+(define (check-lenv stx lenv)
+  (for ([v (in-vector lenv)])
+    (unless v
+      (error 'template "pattern variable used in ellipsis pattern is not defined")))
+  (let ([len0 (length (vector-ref lenv 0))])
+    (for ([v (in-vector lenv)])
+      (unless (= len0 (length v))
+        (raise-syntax-error 'template
+                            "incomplatible ellipsis match counts for template"
+                            stx)))))
+
+;; ----
+
+(define current-template-metafunction-introducer
+  (make-parameter
+   (lambda (stx)
+     (if (syntax-transforming?)
+         (syntax-local-introduce stx)
+         stx))))
+
+;; ----
+
+(define (stx-cadr x) (stx-car (stx-cdr x)))
+(define (stx-cddr x) (stx-cdr (stx-cdr x)))
+(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
+
+(define (stx-drop n x)
+  (cond [(zero? n) x]
+        [else (stx-drop (sub1 n) (stx-cdr x))]))
+
+(define (restx basis val)
+  (if (syntax? basis)
+      (datum->syntax basis val basis basis)
+      val))
+
+;; nested-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
+;; (Actually, in practice onto is stx, so this is an improper append.)
+(define (nested-append lst nesting onto)
+  (cond [(zero? nesting) (append lst onto)]
+        [(null? lst) onto]
+        [else (nested-append (car lst) (sub1 nesting)
+                             (nested-append (cdr lst) nesting onto))]))
+
+(define (check-stx ctx v)
+  (if (syntax? v)
+      v
+      (error/not-stx ctx v)))
+
+(define (error/not-stx ctx v)
+  (raise-syntax-error 'template "pattern variable is not syntax-valued" ctx))
+
+(define (error/bad-index index)
+  (error 'template "internal error: bad index: ~e" index))
+
+(define (vector-car/cdr! dest-v src-v)
+  (let ([len (vector-length dest-v)])
+    (let loop ([i 0])
+      (when (< i len)
+        (let ([p (vector-ref src-v i)])
+          (vector-set! dest-v i (car p))
+          (vector-set! src-v i (cdr p)))
+        (loop (add1 i))))))
+
+(define (vector-map f src-v)
+  (let* ([len (vector-length src-v)]
+         [dest-v (make-vector len)])
+    (let loop ([i 0])
+      (when (< i len)
+        (vector-set! dest-v i (f (vector-ref src-v i)))
+        (loop (add1 i))))
+    dest-v))

collects/syntax/parse/experimental/template.rkt

@@ -2,14 +2,10 @@
 (require (for-syntax racket/base
                      racket/set
                      racket/syntax
-                     racket/match
+                     syntax/parse/private/minimatch
-                     racket/private/sc
+                     racket/private/sc)
-                     unstable/struct)
-         racket/match
-         racket/vector
-         syntax/stx
          syntax/parse/private/residual
-         unstable/struct)
+         "private/substitute.rkt")
 (provide template
          define-template-metafunction
          ??
@@ -22,6 +18,7 @@ To do:
   (with-syntax ([(a ...) #'(1 2 3)]
                 [((b ...) ...) #'((1 2 3) (4 5 6) (7 8 9))])
     #'(((a b) ...) ...))  ;; a has depth 1, used at depth 2
+- support #hash templates, etc (check for other atomic & compound forms)
 |#
 
 #|
@@ -71,6 +68,20 @@ A HeadTemplate (H) is one of:
                                    'guide
                                    (vector var ...)))]))))])))
 
+;; substitute-table : hash[stx => translated-template]
+;; Cache for closure-compiled templates. Key is just syntax of
+;; template, since eq? templates must have equal? guides.
+(define substitute-table (make-weak-hasheq))
+
+(define (substitute stx g main-env)
+  (let ([f (or (hash-ref substitute-table stx #f)
+               (let ([f (translate stx g (vector-length main-env))])
+                 (hash-set! substitute-table stx f)
+                 f))])
+    (f main-env #f)))
+
+;; ----
+
 (define-syntaxes (?? ?@)
   (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
     (values tx tx)))
@@ -78,51 +89,16 @@ A HeadTemplate (H) is one of:
 ;; ============================================================
 
 #|
-A Guide (G) is one of:
+See private/substitute for definition of Guide (G) and HeadGuide (HG).
-  - _
-  - (G . G)
-  - integer
-  - #s(stxvector G)
-  - #s(stxstruct G)
-  - #&G
-  - #s(dots HG (vector-of integer) nat G)
-  - #s(app HG G)
-  - #s(escaped G)
-  - #s(orelse G (vector-of integer) G)
-  - #s(metafun integer G)
-  "optimized" forms:
-  - #s(sdots G integer G) ; simple head template, one driver, nesting=1
 
-A HeadGuide (HG) is one of:
+An env-entry is one of
-  - G
+  - syntax-mapping (for pattern variables)
-  - #s(app-opt G (vector-of integer))
+  - template-metafunction
-  - #s(splice G)
 
-A Pre-Guide is like a Guide but with pvars and pvar sets instead of
+A Pre-Guide is like a Guide but with env-entry and (setof env-entry)
-integers and integer vectors.
+instead of integers and integer vectors.
 |#
 
-(define-syntax-rule (begin-both-phases form ...)
-  (begin (begin-for-syntax form ...)
-         (begin form ...)))
-
-(begin-both-phases
- (struct stxvector (g) #:prefab)
- (struct stxstruct (g) #:prefab)
- (struct dots (head hdrivers nesting tail) #:prefab)
- (struct app (head tail) #:prefab)
- (struct escaped (body) #:prefab)
- (struct orelse (g1 drivers1 g2) #:prefab)
- (struct metafun (index g) #:prefab)
- (struct app-opt (g drivers) #:prefab)
- (struct splice (g) #:prefab)
-
- (struct sdots (head driver tail) #:prefab)
-
- (define (head-guide? x)
-   (or (app-opt? x) (splice? x)))
- )
-
 ;; ============================================================
 
 (define-syntax (define-template-metafunction stx)
@@ -143,70 +119,73 @@ integers and integer vectors.
 
 (begin-for-syntax
 
+ ;; parse-template : stx -> (values guide (vectorof env-entry))
  (define (parse-template t)
-   (let-values ([(_const? drivers pre-guide) (parse-t t 0 #f)])
+   (let-values ([(drivers pre-guide) (parse-t t 0 #f)])
-     (define (set->env drivers)
-       (for/hash ([pvar (in-set drivers)]
-                  [n (in-naturals 1)])
-         (values pvar n)))
      (define main-env (set->env drivers))
-     (define (loop g loop-env)
+     (define guide (guide-resolve-env pre-guide main-env))
-       (define (get-index x)
-         (let ([loop-index (hash-ref loop-env x #f)])
-           (if loop-index
-               (- loop-index)
-               (hash-ref main-env x))))
-       (match g
-         ['_ '_]
-         [(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))]
-         [(? syntax-pattern-variable? pvar) (get-index pvar)]
-         [(dots head hdrivers nesting tail)
-          (cond [(and (= nesting 1)
-                      (= (set-count hdrivers) 1)
-                      (not (head-guide? head)))
-                 (let* ([pvar (for/first ([pvar (in-set hdrivers)]) pvar)]
-                        [sub-loop-env (hash pvar 0)])
-                   (sdots (loop head sub-loop-env)
-                          (get-index pvar)
-                          (loop tail loop-env)))]
-                [else
-                 (let* ([sub-loop-env (set->env hdrivers)]
-                        [sub-loop-vector (index-hash->vector sub-loop-env get-index)])
-                   (dots (loop head sub-loop-env)
-                         sub-loop-vector
-                         nesting
-                         (loop tail loop-env)))])]
-         [(app head tail)
-          (app (loop head loop-env) (loop tail loop-env))]
-         [(escaped g1)
-          (escaped (loop g1 loop-env))]
-         [(orelse g1 drivers1 g2)
-          (orelse (loop g1 loop-env)
-                  (for/vector ([pvar (in-set drivers1)])
-                    (get-index pvar))
-                  (loop g2 loop-env))]
-         [(metafun mf g1)
-          (metafun (get-index mf)
-                   (loop g1 loop-env))]
-         [(stxvector g1)
-          (stxvector (loop g1 loop-env))]
-         [(stxstruct g1)
-          (stxstruct (loop g1 loop-env))]
-         [(? box?)
-          (box (loop (unbox g) loop-env))]
-         [(app-opt g1 drivers1)
-          (app-opt (loop g1 loop-env)
-                   (for/vector ([pvar (in-set drivers1)])
-                     (get-index pvar)))]
-         [(splice g1)
-          (splice (loop g1 loop-env))]
-         [else (error 'template "internal error: bad pre-guide: ~e" g)]))
-     (define guide (loop pre-guide #hash()))
      (values guide
              (index-hash->vector main-env))))
 
+ ;; set->env : (setof env-entry) -> hash[env-entry => nat]
+ (define (set->env drivers)
+   (for/hash ([pvar (in-set drivers)]
+              [n (in-naturals 1)])
+     (values pvar n)))
+
+ ;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide
+ (define (guide-resolve-env g0 main-env)
+   (define (loop g loop-env)
+     (define (get-index x)
+       (let ([loop-index (hash-ref loop-env x #f)])
+         (if loop-index
+             (- loop-index)
+             (hash-ref main-env x))))
+     (match g
+       ['_ '_]
+       [(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))]
+       [(? syntax-pattern-variable? pvar) (get-index pvar)]
+       [(vector 'dots head hdrivers nesting tail)
+        (let* ([sub-loop-env (set->env hdrivers)]
+               [sub-loop-vector (index-hash->vector sub-loop-env get-index)])
+          (vector 'dots
+                  (loop head sub-loop-env)
+                  sub-loop-vector
+                  nesting
+                  (loop tail loop-env)))]
+       [(vector 'app head tail)
+        (vector 'app (loop head loop-env) (loop tail loop-env))]
+       [(vector 'escaped g1)
+        (vector 'escaped (loop g1 loop-env))]
+       [(vector 'orelse g1 drivers1 g2)
+        (vector 'orelse
+                (loop g1 loop-env)
+                (for/vector ([pvar (in-set drivers1)])
+                  (get-index pvar))
+                (loop g2 loop-env))]
+       [(vector 'metafun mf g1)
+        (vector 'metafun
+                (get-index mf)
+                (loop g1 loop-env))]
+       [(vector 'vector g1)
+        (vector 'vector (loop g1 loop-env))]
+       [(vector 'struct g1)
+        (vector 'struct (loop g1 loop-env))]
+       [(vector 'box g1)
+        (vector 'box (loop (unbox g) loop-env))]
+       [(vector 'app-opt g1 drivers1)
+        (vector 'app-opt
+                (loop g1 loop-env)
+                (for/vector ([pvar (in-set drivers1)])
+                  (get-index pvar)))]
+       [(vector 'splice g1)
+        (vector 'splice (loop g1 loop-env))]
+       [else (error 'template "internal error: bad pre-guide: ~e" g)]))
+   (loop g0 '#hash()))
+
  ;; ----------------------------------------
 
+ ;; parse-t : stx nat boolean -> (values (setof env-entry) pre-guide)
  (define (parse-t t depth esc?)
    (syntax-case t (?? ?@)
      [id
@@ -219,34 +198,32 @@ integers and integer vectors.
             [else
              (let ([pvar (lookup #'id depth)])
                (cond [(syntax-pattern-variable? pvar)
-                      (values #f (set pvar) pvar)]
+                      (values (set pvar) pvar)]
                      [(template-metafunction? pvar)
                       (wrong-syntax t "illegal use of syntax metafunction")]
-                     [else (values #t (set) '_)]))])]
+                     [else (values (set) '_)]))])]
      [atom
       (atom? (syntax-e #'atom))
-      (values #t (set) '_)]
+      (values (set) '_)]
      [(mf . template)
       (and (not esc?)
            (identifier? #'mf)
            (template-metafunction? (lookup #'mf #f)))
       (let-values ([(mf) (lookup #'mf #f)]
-                   [(const? drivers guide) (parse-t #'template depth esc?)])
+                   [(drivers guide) (parse-t #'template depth esc?)])
-        (values #f
+        (values (set-union (set mf) drivers)
-                (set-union (set mf) drivers)
+                (vector 'metafun mf guide)))]
-                (metafun mf guide)))]
      [(DOTS template)
       (and (not esc?)
            (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
-      (let-values ([(const? drivers guide) (parse-t #'template depth #t)])
+      (let-values ([(drivers guide) (parse-t #'template depth #t)])
-        (values #f drivers (escaped guide)))]
+        (values drivers (vector 'escaped guide)))]
      [(?? t1 t2)
       (not esc?)
-      (let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)]
+      (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)]
-                   [(const2? drivers2 guide2) (parse-t #'t2 depth esc?)])
+                   [(drivers2 guide2) (parse-t #'t2 depth esc?)])
-        (values #f
+        (values (set-union drivers1 drivers2)
-                (set-union drivers1 drivers2)
+                (vector 'orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))]
-                (orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))]
      [(head DOTS . tail)
       (and (not esc?)
            (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
@@ -257,48 +234,47 @@ integers and integer vectors.
                          (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
                          (loop (add1 nesting) #'tail)]
                         [else (values nesting tail)]))])
-        (let-values ([(hconst? hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)]
+        (let-values ([(hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)]
-                     [(tconst? tdrivers tguide) (parse-t tail depth esc?)])
+                     [(tdrivers tguide) (parse-t tail depth esc?)])
           (unless (positive? (set-count hdrivers))
             (wrong-syntax #'head "no pattern variables in term before ellipsis"))
-          (values #f
+          (values (set-union hdrivers tdrivers)
-                  (set-union hdrivers tdrivers)
+                  (vector 'dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))]
-                  (dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))]
      [(head . tail)
-      (let-values ([(hconst? hdrivers hsplice? hguide) (parse-h #'head depth esc?)]
+      (let-values ([(hdrivers hsplice? hguide) (parse-h #'head depth esc?)]
-                   [(tconst? tdrivers tguide) (parse-t #'tail depth esc?)])
+                   [(tdrivers tguide) (parse-t #'tail depth esc?)])
-        (let ([const? (and hconst? tconst?)])
+        (values (set-union hdrivers tdrivers)
-          (values const?
+                (cond [(and (eq? hguide '_) (eq? tguide '_)) '_]
-                  (set-union hdrivers tdrivers)
+                      [hsplice? (vector 'app hguide tguide)]
-                  (cond [const? '_]
+                      [else (cons hguide tguide)])))]
-                        [hsplice? (app hguide tguide)]
-                        [else (cons hguide tguide)]))))]
      [vec
       (vector? (syntax-e #'vec))
-      (let-values ([(const? drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
+      (let-values ([(drivers guide) (parse-t (vector->list (syntax-e #'vec)) depth esc?)])
-        (values const? drivers (if const? '_ (stxvector guide))))]
+        (values drivers (if (eq? guide '_) '_ (vector 'vector guide))))]
      [pstruct
       (prefab-struct-key (syntax-e #'pstruct))
-      (let-values ([(const? drivers guide) (parse-t (struct->list (syntax-e #'pstruct)) depth esc?)])
+      (let-values ([(drivers guide)
-        (values const? drivers (if const? '_ (stxstruct guide))))]
+                    (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
+        (values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
      [#&template
-      (let-values ([(const? drivers guide) (parse-t #'template depth esc?)])
+      (let-values ([(drivers guide) (parse-t #'template depth esc?)])
-        (values const? drivers (if const? '_ (box guide))))]
+        (values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
-     [_ (wrong-syntax t "bad pattern")]))
+     [_ (wrong-syntax t "bad template")]))
 
+ ;; parse-h : stx nat boolean -> (values (setof env-entry) boolean pre-head-guide)
  (define (parse-h h depth esc?)
    (syntax-case h (?? ?@)
      [(?? t)
       (not esc?)
-      (let-values ([(const? drivers guide) (parse-t #'t depth esc?)])
+      (let-values ([(drivers guide) (parse-t #'t depth esc?)])
-        (values #f drivers #t (app-opt guide (set-filter drivers syntax-pattern-variable?))))]
+        (values drivers #t (vector 'app-opt guide (set-filter drivers syntax-pattern-variable?))))]
      [(?@ . t)
       (not esc?)
-      (let-values ([(const? drivers guide) (parse-t #'t depth esc?)])
+      (let-values ([(drivers guide) (parse-t #'t depth esc?)])
-        (values #f drivers #t (splice guide)))]
+        (values drivers #t (vector 'splice guide)))]
      [t
-      (let-values ([(const? drivers guide) (parse-t #'t depth esc?)])
+      (let-values ([(drivers guide) (parse-t #'t depth esc?)])
-        (values const? drivers #f guide))]))
+        (values drivers #f guide))]))
 
  (define (atom? x)
    (or (null? x)
@@ -349,136 +325,4 @@ integers and integer vectors.
  (define (pvar/depth>0? x)
    (and (syntax-pattern-variable? x)
         (positive? (syntax-mapping-depth x))))
-
  )
-
-;; ============================================================
-
-(define (substitute stx g main-env)
-  (define (get index lenv)
-    (cond [(positive? index)
-           (vector-ref main-env (sub1 index))]
-          [(negative? index)
-           (vector-ref lenv (- -1 index))]
-          [(zero? index) lenv]))
-  (define (loop stx g lenv)
-    (match g
-      ['_ stx]
-      [(cons g1 g2)
-       (restx stx (cons (loop (stx-car stx) g1 lenv) (loop (stx-cdr stx) g2 lenv)))]
-      [(? exact-integer? index)
-       (let ([v (get index lenv)])
-         (if (syntax? v)
-             v
-             (error/not-stx stx v)))]
-      [(sdots ghead loop-var gtail)
-       (let ([lenv* (get loop-var lenv)])
-         (unless lenv* (error 'template "pattern variable used in ellipsis pattern is not defined"))
-         (restx stx
-                (if (equal? ghead '0) ;; pattern was just (pvar ... . T)
-                    (append lenv* (loop (stx-cddr stx) gtail lenv))
-                    (let ([head-stx (stx-car stx)])
-                      (let dotsloop ([lenv* lenv*])
-                        (if (null? lenv*)
-                            (loop (stx-cddr stx) gtail lenv)
-                            (cons (loop head-stx ghead (car lenv*))
-                                  (dotsloop (cdr lenv*)))))))))]
-      [(dots ghead henv nesting gtail)
-       (define head-stx (stx-car stx))
-       (define (nestloop lenv* nesting)
-         (cond [(zero? nesting)
-                (loop-h head-stx ghead lenv*)]
-               [else
-                (for ([v (in-vector lenv*)])
-                  (unless v (error 'template "pattern variable used in ellipsis pattern is not defined")))
-                (let ([len0 (length (vector-ref lenv* 0))])
-                  (for ([v (in-vector lenv*)])
-                    (unless (= len0 (length v))
-                      (raise-syntax-error 'template
-                                          "incomplatible ellipsis match counts for template"
-                                          stx)))
-                  (let dotsloop ([len0 len0] [lenv* lenv*])
-                    (if (zero? len0)
-                        null
-                        (let ([lenv** (vector-map car lenv*)])
-                          (cons (nestloop lenv** (sub1 nesting))
-                                (dotsloop (sub1 len0) (vector-map! cdr lenv*)))))))]))
-       (let ([head-results ;; (listof^nesting (listof stx)) -- extra listof for loop-h
-              (nestloop (vector-map (lambda (index) (get index lenv)) henv) nesting)]
-             [tail-result (loop (stx-drop nesting (stx-cdr stx)) gtail lenv)])
-         (restx stx (deep-append head-results nesting tail-result)))]
-      [(app ghead gtail)
-       (restx stx (append (loop-h (stx-car stx) ghead lenv)
-                          (loop (stx-cdr stx) gtail lenv)))]
-      [(escaped g1)
-       (loop (stx-cadr stx) g1 lenv)]
-      [(orelse g1 drivers1 g2)
-       (if (for/and ([index (in-vector drivers1)]) (get index lenv))
-           (loop (stx-cadr stx) g1 lenv)
-           (loop (stx-caddr stx) g2 lenv))]
-      [(metafun index g1)
-       (let ([v (restx stx (cons (stx-car stx) (loop (stx-cdr stx) g1 lenv)))]
-             [mark (make-syntax-introducer)]
-             [old-mark (current-template-metafunction-introducer)]
-             [mf (get index lenv)])
-         (parameterize ((current-template-metafunction-introducer mark))
-           (let ([r (mf (mark (old-mark v)))])
-             (unless (syntax? r)
-               (raise-syntax-error 'template "result of metafunction was not syntax" stx))
-             (restx stx (old-mark (mark r))))))]
-      [(stxvector g1)
-       (restx stx (list->vector (loop (vector->list (syntax-e stx)) g1 lenv)))]
-      [(stxstruct g1)
-       (let ([s (syntax-e stx)])
-         (restx stx (apply make-prefab-struct
-                           (prefab-struct-key s)
-                           (loop (struct->list s) g1 lenv))))]
-      [(box g1)
-       (restx stx (box (loop (unbox (syntax-e stx)) g1 lenv)))]))
-  (define (loop-h stx hg lenv)
-    (match hg
-      [(app-opt g1 drivers1)
-       (if (for/and ([index (in-vector drivers1)]) (get index lenv))
-           (list (loop (stx-cadr stx) g1 lenv))
-           null)]
-      [(splice g1)
-       (let* ([v (loop (stx-cdr stx) g1 lenv)]
-              [v* (stx->list v)])
-         (unless v*
-           (raise-syntax-error 'template
-                               "splicing template did not produce a syntax list"
-                               stx))
-         v*)]
-      [else (list (loop stx hg lenv))]))
-  (loop stx g #f))
-
-(define current-template-metafunction-introducer
-  (make-parameter
-   (lambda (stx)
-     (if (syntax-transforming?)
-         (syntax-local-introduce stx)
-         stx))))
-
-(define (stx-cadr x) (stx-car (stx-cdr x)))
-(define (stx-cddr x) (stx-cdr (stx-cdr x)))
-(define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x))))
-
-(define (stx-drop n x)
-  (cond [(zero? n) x]
-        [else (stx-drop (sub1 n) (stx-cdr x))]))
-
-(define (restx basis val)
-  (if (syntax? basis)
-      (datum->syntax basis val basis basis)
-      val))
-
-;; deep-append : (listof^(nesting+1) A) nat (listof A) -> (listof A)
-;; (Actually, in practice onto is stx, so this is an improper append.)
-(define (deep-append lst nesting onto)
-  (cond [(null? lst) onto]
-        [(zero? nesting) (append lst onto)]
-        [else (deep-append (car lst) (sub1 nesting)
-                           (deep-append (cdr lst) nesting onto))]))
-
-(define (error/not-stx stx val)
-  (raise-syntax-error 'template "pattern variable is not syntax-valued" stx))

collects/syntax/parse/private/minimatch.rkt

@@ -25,7 +25,7 @@
 
 ;; (match-p id Pattern SuccessExpr FailureExpr)
 (define-syntax (match-p stx)
-  (syntax-case stx (quote cons list make struct ?)
+  (syntax-case stx (quote cons list vector make struct ?)
     [(match-p x wildcard success failure)
      (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
      #'success]
@@ -43,6 +43,11 @@
      #'(match-p x (quote ()) success failure)]
     [(match-p x (list p1 p ...) success failure)
      #'(match-p x (cons p1 (list p ...)) success failure)]
+    [(match-p x (vector p ...) success failure)
+     #'(if (and (vector? x) (= (vector-length x) (length '(p ...))))
+           (let ([x* (vector->list x)])
+             (match-p x* (list p ...) success failure))
+           failure)]
     [(match-p x var success failure)
      (identifier? #'var)
      #'(let ([var x]) success)]

collects/tests/stxparse/stress-template.rkt

@@ -0,0 +1,77 @@
+#lang racket/base
+(require syntax/parse/experimental/template)
+(provide (all-defined-out))
+
+(define (f1-stx stx)
+  (syntax-case stx ()
+    [(_ body)
+     #'(discard-exn body #f)]
+    [(_ body on-exn)
+     #'(with-handlers ([not-break-exn? (lambda (_) on-exn)])
+         body)]))
+
+(define (f1-tmpl stx)
+  (syntax-case stx ()
+    [(_ body)
+     (template (discard-exn body #f))]
+    [(_ body on-exn)
+     (template (with-handlers ([not-break-exn? (lambda (_) on-exn)])
+                 body))]))
+
+(define (f2-stx stx)
+  (syntax-case stx ()
+    [(_ (x ...) (y ...) z)
+     #'((x z) ... ((y x) ... z))]))
+
+(define (f2-tmpl stx)
+  (syntax-case stx ()
+    [(_ (x ...) (y ...) z)
+     (template ((x z) ... ((y x) ... z)))]))
+
+(define (f3-stx stx)
+  (syntax-case stx ()
+    [(_ (x ...) (y ...) z)
+     #'((x 1) ... ((y 2) ... z))]))
+
+(define (f3-tmpl stx)
+  (syntax-case stx ()
+    [(_ (x ...) (y ...) z)
+     (template ((x 1) ... ((y 2) ... z)))]))
+
+(define (test f term)
+  (collect-garbage)
+  (time (void (for ([i #e1e5]) (f term)))))
+
+(define stx2a
+  #`(_
+     #,(for/list ([i 10]) i)
+     #,(for/list ([i 10]) 'a)
+     z))
+
+(define stx2
+  #`(_
+     #,(for/list ([i 100]) i)
+     #,(for/list ([i 100]) 'a)
+     z))
+
+(define prog
+  '((test f1-stx #'(_ e))
+    (test f1-tmpl #'(_ e))
+
+    (test f2-stx stx2a)
+    (test f2-tmpl stx2a)
+
+    (test f2-stx stx2)
+    (test f2-tmpl stx2)
+
+    (test f3-stx stx2a)
+    (test f3-tmpl stx2a)
+
+    (test f3-stx stx2)
+    (test f3-tmpl stx2)))
+
+(define-namespace-anchor nsa)
+
+(for ([p prog])
+  (printf "> ~s\n" p)
+  (eval p (namespace-anchor->namespace nsa)))