www

commit 1f58e9728294b1e85ae418d258f7cad8f88c2ba8
parent 5eac499ec4fc4203c0ff72c006dfd1735944d519
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Wed, 16 Aug 2017 20:33:15 -0400

syntax/parse template: add simple ellipsis special case

Diffstat:
M
parse/experimental/template.rkt
 | 
21
++++++++++++++++-----

1 file changed, 16 insertions(+), 5 deletions(-)
diff --git a/parse/experimental/template.rkt b/parse/experimental/template.rkt
@@ -66,8 +66,8 @@
 ;; - (list 't-vector G)
 ;; - (list 't-struct G)
 ;; - (list 't-box G)
-;; - (list 't-dots HG (listof (listof PVar)) Nat G #f Boolean)
-;; - (list 't-dots  G (listof (listof PVar)) Nat G #t Boolean)
+;; - (list 't-dots HG (listof (listof PVar)) Nat G/#f #f Boolean)
+;; - (list 't-dots  G (listof (listof PVar)) Nat G/#f #t Boolean)
 ;; - (list 't-append/p HG G)  ;; template is non-syntax pair => no restx, use {car,cdr}
 ;; - (list 't-append/x HG G)  ;; template is syntax-pair => restx, use {car,cdr}+syntax-e
 ;; - (list 't-escaped G)
@@ -190,7 +190,10 @@
      (if (zero? nesting)
          (parse-t-pair/normal t depth esc? in-try?)
          (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)]
-                      [(tdrivers tguide) (parse-t tail depth esc? in-try?)])
+                      [(tdrivers tguide)
+                       (if (null? tail)
+                           (values (dset) #f)
+                           (parse-t tail depth esc? in-try?))])
            (when (dset-empty? hdrivers)
              (wrong-syntax head "no pattern variables before ellipsis in template"))
            (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
@@ -511,10 +514,18 @@
 
 (define-syntax (t-dots stx)
   (syntax-case stx ()
+    ;; Case 1: (x ...) where x is trusted.
+    [(t-dots (t-var #s(pvar _ lvar #f _) _) _drivers 1 #f #t _)
+     (begin
+       (log-template-debug "dots case 1: (x ...) where x is trusted")
+       #'(lambda (stx) (restx stx lvar)))]
+    ;; General case
     [(t-dots head ((#s(pvar _ lvar check? _) ...) ...) nesting tail cons? in-try?)
      (let ([cons? (syntax-e #'cons?)]
            [lvarss (map syntax->list (syntax->list #'((lvar ...) ...)))]
            [check?ss (syntax->datum #'((check? ...) ...))])
+       (log-template-debug "dots general case: nesting = ~s, cons? = ~s, #vars = ~s"
+                           (syntax-e #'nesting) cons? (apply + (map length lvarss)))
        ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
        ;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
        ;;          -> Syntax[(Listof AccElem) -> (Listof AccElem)]
@@ -542,8 +553,8 @@
                   (gen-level lvars* check?s*
                              (nestloop (cdr lvarss) (cdr check?ss) lvars* check?s*))])))
        (if cons?
-           #`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting tail)
-           #`(t-dots*  (lambda (stx) (#,head-loop-code null)) nesting tail)))]))
+           #`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))
+           #`(t-dots*  (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))))]))
 
 (begin-encourage-inline