suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syntax/parse template: add simple ellipsis special case

Browse Source
This commit is contained in:
Ryan Culpepper 2017-08-16 20:33:15 -04:00
parent 50cb7fbaf7
commit 723140720e
2 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/racket-test/tests/stxparse/stress-template.rkt
View File

@ -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)

21
racket/collects/syntax/parse/experimental/template.rkt
View File

@ -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