From 723140720e6e2f6b059a65121dcee1cfa20df507 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 16 Aug 2017 20:33:15 -0400 Subject: [PATCH] syntax/parse template: add simple ellipsis special case --- .../tests/stxparse/stress-template.rkt | 18 +++++++++++++++- .../syntax/parse/experimental/template.rkt | 21 ++++++++++++++----- 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/pkgs/racket-test/tests/stxparse/stress-template.rkt b/pkgs/racket-test/tests/stxparse/stress-template.rkt index 194884a447..4f6111e497 100644 --- a/pkgs/racket-test/tests/stxparse/stress-template.rkt +++ b/pkgs/racket-test/tests/stxparse/stress-template.rkt @@ -40,6 +40,16 @@ [(_ (x ...) (y ...) z) (template ((x 1) ... ((y 2) ... z)))])) +(define (f4-stx stx) ;; test common ellipsis case + (syntax-case stx () + [(_ (x ...) (y ...) z) + #'(blah (x ...) (y ...) z)])) + +(define (f4-tmpl stx) + (syntax-case stx () + [(_ (x ...) (y ...) z) + (template (blah (x ...) (y ...) z))])) + (define (test f term) (collect-garbage) (time (void (for ([i #e1e5]) (f term))))) @@ -70,7 +80,13 @@ (test f3-tmpl stx2a)) ((test f3-stx stx2) - (test f3-tmpl stx2)))) + (test f3-tmpl stx2)) + + ((test f4-stx stx2a) + (test f4-tmpl stx2a)) + + ((test f4-stx stx2) + (test f4-tmpl stx2)))) (define-namespace-anchor nsa) diff --git a/racket/collects/syntax/parse/experimental/template.rkt b/racket/collects/syntax/parse/experimental/template.rkt index 62eb9173ff..1c4f454e02 100644 --- a/racket/collects/syntax/parse/experimental/template.rkt +++ b/racket/collects/syntax/parse/experimental/template.rkt @@ -61,8 +61,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) @@ -185,7 +185,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))) @@ -503,10 +506,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)] @@ -534,8 +545,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