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

syntax/parse template: compile = datum->syntax

Browse Source 
Change guide reps to coincide with expressions for template compilation.
This commit is contained in:
Ryan Culpepper 2017-08-13 07:47:41 -04:00 committed by Georges Dupéron
parent 1e0eb983a9
commit 5eac499ec4
1 changed files with 311 additions and 371 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

682
parse/experimental/template.rkt
View File

@ -54,32 +54,42 @@
;; Parse template syntax into a Guide (AST--the name is left over from ;; Parse template syntax into a Guide (AST--the name is left over from
;; when the "guide" was a data structure interpreted at run time). ;; when the "guide" was a data structure interpreted at run time).
;; The AST representation is designed to coincide with the run-time
;; support, so compilation is just (datum->syntax #'here guide).
;; A Guide (G) is one of: ;; A Guide (G) is one of:
;; - '_ ;; constant ;; - (list 't-const) ;; constant
;; - PVar ;; pattern variable ;; - (list 't-var PVar Boolean) ;; pattern variable
;; - (vector 'cons G G) ;; template is pair or syntax-pair => restx, use stx-{car,cdr} ;; - (list 't-cons G G) ;; template is pair or syntax-pair => restx, use stx-{car,cdr}
;; - (vector 'cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr} ;; - (list 't-cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr}
;; - (vector 'cons/x G G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e ;; - (list 't-cons/x G G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e
;; - (vector 'vector G) ;; - (list 't-vector G)
;; - (vector 'struct G) ;; - (list 't-struct G)
;; - (vector 'box G) ;; - (list 't-box G)
;; - (vector 'dots HG (listof (listof PVar)) Nat G) ;; - (list 't-dots HG (listof (listof PVar)) Nat G #f Boolean)
;; - (vector 'append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr} ;; - (list 't-dots G (listof (listof PVar)) Nat G #t Boolean)
;; - (vector 'append/x HG G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e ;; - (list 't-append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr}
;; - (vector 'escaped G) ;; - (list 't-append/x HG G) ;; template is syntax-pair => restx, use {car,cdr}+syntax-e
;; - (vector 'orelse G G) ;; - (list 't-escaped G)
;; - (vector 'metafun Metafunction G) ;; - (list 't-orelse G G)
;; - (vector 'unsyntax Id) ;; - (list 't-metafun Id G)
;; - (vector 'relocate G Id) ;; - (list 't-unsyntax Id)
;; - (list 't-relocate G Id)
;; For 't-var and 't-dots, the final boolean indicates whether the template
;; fragment is in the left-hand side of an orelse (??).
;; A HeadGuide (HG) is one of: ;; A HeadGuide (HG) is one of:
;; - G ;; - (list 'h-t G)
;; - (vector 'orelse-h1 H) ;; - (list 'h-orelse HG HG/#f)
;; - (vector 'orelse-h H H) ;; - (list 'h-splice G)
;; - (vector 'splice G) ;; - (list 'h-unsyntax-splicing Id)
;; - (vector 'unsyntax-splicing Id)
;; A PVar is (pvar syntax-mapping attribute-mapping/#f depth-delta) ;; A PVar is (pvar Id Id Boolean Nat/#f)
;;
;; The first identifier (var) is from the syntax-mapping or attribute-binding.
;; The second (lvar) is a local variable name used to hold its value (or parts
;; thereof) in ellipsis iteration. The boolean is #f if var is trusted to have a
;; (Listof^depth Syntax) value, #t if it needs to be checked.
;; ;;
;; The depth-delta associated with a depth>0 pattern variable is the difference ;; The depth-delta associated with a depth>0 pattern variable is the difference
;; between the pattern variable's depth and the depth at which it is used. (For ;; between the pattern variable's depth and the depth at which it is used. (For
@ -107,209 +117,220 @@
(define-logger template) (define-logger template)
(struct pvar (sm attr dd) #:prefab) (struct pvar (var lvar check? dd) #:prefab)
(struct template-metafunction (var)) (struct template-metafunction (var))
(define (head-guide? x) (define (ht-guide? x) (match x [(list 'h-t _) #t] [_ #f]))
(match x (define (ht-guide-t x) (match x [(list 'h-t g) g]))
[(vector 'orelse-h1 g) #t]
[(vector 'splice g) #t] (define const-guide '(t-const))
[(vector 'orelse-h g1 g2) #t] (define (const-guide? x) (equal? x const-guide))
[(vector 'unsyntax-splicing var) #t]
[_ #f]))
;; ---------------------------------------- ;; ----------------------------------------
;; Parsing templates ;; Parsing templates
;; parse-t : Stx Nat Boolean -> (values (dsetof PVar) Guide) ;; parse-template : Syntax -> (values (listof PVar) Guide)
(define (parse-t t depth esc?) (define (parse-template t)
(cond [(stx-pair? t) ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ]
(if (identifier? (stx-car t)) (define env (make-hasheq))
(parse-t-pair/command t depth esc?)
(parse-t-pair/dots t depth esc?))]
[else (parse-t-nonpair t depth esc?)]))
;; parse-t-pair/command : Stx Nat Boolean -> ... ;; parse-t : Stx Nat Boolean Boolean -> (values (dsetof PVar) Guide)
;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) (define (parse-t t depth esc? in-try?)
(define (parse-t-pair/command t depth esc?) (cond [(stx-pair? t)
(syntax-case t (quasitemplate unsyntax ??) (if (identifier? (stx-car t))
[(quasitemplate template) (parse-t-pair/command t depth esc? in-try?)
(quasi) (parse-t-pair/dots t depth esc? in-try?))]
(parameterize ((quasi (list (quasi)))) [else (parse-t-nonpair t depth esc? in-try?)]))
(let-values ([(drivers guide) (parse-t #'template depth esc?)])
(values drivers (list-guide '_ guide))))]
[(unsyntax e)
(quasi)
(let ([qval (quasi)])
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
(set-box! qval (cons (cons #'tmp t) (unbox qval)))
(values (dset) (vector 'unsyntax #'tmp)))]
[else
(parameterize ((quasi (car qval)))
(let-values ([(drivers guide) (parse-t #'e depth esc?)])
(values drivers (list-guide '_ guide))))]))]
[(DOTS template)
(and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...)))
(let-values ([(drivers guide) (parse-t #'template depth #t)])
(values drivers (vector 'escaped guide)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 guide1) (parse-t #'t1 depth esc?)]
[(drivers2 guide2) (parse-t #'t2 depth esc?)])
(values (dset-union drivers1 drivers2) (vector 'orelse guide1 guide2)))]
[(mf . _)
(and (not esc?) (template-metafunction? (lookup #'mf #f)))
(let-values ([(mf) (lookup #'mf #f)]
[(drivers guide) (parse-t (stx-cdr t) depth esc?)])
(values drivers (vector 'metafun mf guide)))]
[_ (parse-t-pair/dots t depth esc?)]))
;; parse-t-pair/dots : Stx Nat Boolean -> ... ;; parse-t-pair/command : Stx Nat Boolean Boolean -> ...
;; t is a stx pair; check for dots ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc)
(define (parse-t-pair/dots t depth esc?) (define (parse-t-pair/command t depth esc? in-try?)
(define head (stx-car t)) (syntax-case t (quasitemplate unsyntax ??)
(define-values (tail nesting) [(quasitemplate template)
(let loop ([tail (stx-cdr t)] [nesting 0]) (quasi)
(if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail))) (parameterize ((quasi (list (quasi))))
(loop (stx-cdr tail) (add1 nesting)) (let-values ([(drivers guide) (parse-t #'template depth esc? in-try?)])
(values tail nesting)))) (values drivers (list-guide const-guide guide))))]
(if (zero? nesting) [(unsyntax e)
(parse-t-pair/normal t depth esc?) (quasi)
(let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc?)] (let ([qval (quasi)])
[(tdrivers tguide) (parse-t tail depth esc?)]) (cond [(box? qval)
(when (dset-empty? hdrivers) (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))])
(wrong-syntax head "no pattern variables before ellipsis in template")) (set-box! qval (cons (cons #'tmp t) (unbox qval)))
(when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) (values (dset) `(t-unsyntax ,#'tmp)))]
(let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one [else
(stx-car (stx-drop nesting t))]) (parameterize ((quasi (car qval)))
;; FIXME: improve error message? (let-values ([(drivers guide) (parse-t #'e depth esc? in-try?)])
(wrong-syntax bad-dots "too many ellipses in template"))) (values drivers (list-guide const-guide guide))))]))]
(values (dset-union hdrivers tdrivers) [(DOTS template)
;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level (and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...)))
(let* ([hdrivers/level (let-values ([(drivers guide) (parse-t #'template depth #t in-try?)])
(for/list ([i (in-range nesting)]) (values drivers `(t-escaped ,guide)))]
(dset-filter hdrivers (pvar/dd<=? (+ depth i))))] [(?? t1 t2)
[new-hdrivers/level (not esc?)
(let loop ([raw hdrivers/level] [last (dset)]) (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc? #t)]
(cond [(null? raw) null] [(drivers2 guide2) (parse-t #'t2 depth esc? in-try?)])
[else (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))]
(cons (dset->list (dset-subtract (car raw) last)) [(mf . _)
(loop (cdr raw) (car raw)))]))]) (and (not esc?) (lookup-metafun #'mf))
(vector 'dots hguide new-hdrivers/level nesting tguide)))))) (let-values ([(mf) (lookup-metafun #'mf)]
[(drivers guide) (parse-t (stx-cdr t) depth esc? in-try?)])
(values drivers `(t-metafun ,(template-metafunction-var mf) ,guide)))]
[_ (parse-t-pair/dots t depth esc? in-try?)]))
;; parse-t-pair/normal : Stx Nat Boolean -> ... ;; parse-t-pair/dots : Stx Nat Boolean Boolean -> ...
;; t is a normal stx pair ;; t is a stx pair; check for dots
(define (parse-t-pair/normal t depth esc?) (define (parse-t-pair/dots t depth esc? in-try?)
(define-values (hdrivers hguide) (parse-h (stx-car t) depth esc?)) (define head (stx-car t))
(define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc?)) (define-values (tail nesting)
(values (dset-union hdrivers tdrivers) (let loop ([tail (stx-cdr t)] [nesting 0])
(let ([kind (if (head-guide? hguide) (if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail)))
(if (syntax? t) 'append/x 'append/p) (loop (stx-cdr tail) (add1 nesting))
(if (syntax? t) 'cons/x 'cons/p))]) (values tail nesting))))
(vector kind hguide tguide)))) (if (zero? nesting)
(parse-t-pair/normal t depth esc? in-try?)
;; parse-t-nonpair : Stx Nat Boolean -> ... (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)]
;; PRE: t is not a stxpair [(tdrivers tguide) (parse-t tail depth esc? in-try?)])
(define (parse-t-nonpair t depth esc?) (when (dset-empty? hdrivers)
(syntax-case t (?? ?@ unsyntax quasitemplate) (wrong-syntax head "no pattern variables before ellipsis in template"))
[id (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth)))
(identifier? #'id) (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one
(cond [(or (and (not esc?) (stx-car (stx-drop nesting t))])
(or (free-identifier=? #'id (quote-syntax ...)) ;; FIXME: improve error message?
(free-identifier=? #'id (quote-syntax ??)) (wrong-syntax bad-dots "too many ellipses in template")))
(free-identifier=? #'id (quote-syntax ?@)))) ;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level
(and (quasi) (define hdrivers/level
(or (free-identifier=? #'id (quote-syntax unsyntax)) (for/list ([i (in-range nesting)])
(free-identifier=? #'id (quote-syntax unsyntax-splicing))))) (dset-filter hdrivers (pvar/dd<=? (+ depth i)))))
(wrong-syntax #'id "illegal use")] (define new-hdrivers/level
[else (let loop ([raw hdrivers/level] [last (dset)])
(let ([pvar (lookup #'id depth)]) (cond [(null? raw) null]
(cond [(pvar? pvar)
(values (dset pvar) pvar)]
[(template-metafunction? pvar)
(wrong-syntax t "illegal use of syntax metafunction")]
[else [else
(values (dset) '_)]))])] (define level (dset->list (dset-subtract (car raw) last)))
[vec (cons level (loop (cdr raw) (car raw)))])))
(vector? (syntax-e #'vec)) (values (dset-union hdrivers tdrivers)
(let-values ([(drivers guide) (let ([cons? (ht-guide? hguide)]
(parse-t (vector->list (syntax-e #'vec)) depth esc?)]) [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
(values drivers (if (eq? guide '_) '_ (vector 'vector guide))))] `(t-dots ,hguide ,new-hdrivers/level ,nesting ,tguide ,cons? ,in-try?))))))
[pstruct
(prefab-struct-key (syntax-e #'pstruct))
(let-values ([(drivers guide)
(parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)])
(values drivers (if (eq? guide '_) '_ (vector 'struct guide))))]
[#&template
(let-values ([(drivers guide)
(parse-t #'template depth esc?)])
(values drivers (if (eq? guide '_) '_ (vector 'box guide))))]
[const
(values (dset) '_)]))
;; parse-h : Syntax Nat Boolean -> (values (dsetof PVar) HeadGuide) ;; parse-t-pair/normal : Stx Nat Boolean Boolean -> ...
(define (parse-h h depth esc?) ;; t is a normal stx pair
(syntax-case h (?? ?@ unsyntax-splicing) (define (parse-t-pair/normal t depth esc? in-try?)
[(?? t) (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc? in-try?))
(not esc?) (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc? in-try?))
(let-values ([(drivers guide) (parse-h #'t depth esc?)]) (values (dset-union hdrivers tdrivers)
(values drivers (vector 'orelse-h1 guide)))] (let ([kind (cond [(ht-guide? hguide) (if (syntax? t) 't-cons/x 't-cons/p)]
[(?? t1 t2) [else (if (syntax? t) 't-append/x 't-append/p)])]
(not esc?) [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)])
(let-values ([(drivers1 guide1) (parse-h #'t1 depth esc?)] `(,kind ,hguide ,tguide))))
[(drivers2 guide2) (parse-h #'t2 depth esc?)])
(values (dset-union drivers1 drivers2)
(if (or (head-guide? guide1) (head-guide? guide2))
(vector 'orelse-h guide1 guide2)
(vector 'orelse guide1 guide2))))]
[(?@ . _)
(not esc?)
(let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc?)])
(values drivers (vector 'splice guide)))]
[(unsyntax-splicing t1)
(quasi)
(let ([qval (quasi)])
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(values (dset) (vector 'unsyntax-splicing #'tmp)))]
[else
(parameterize ((quasi (car qval)))
(let*-values ([(drivers guide) (parse-t #'t1 depth esc?)]
[(drivers guide) (values drivers (list-guide '_ guide))])
(values drivers guide)))]))]
[t
(let-values ([(drivers guide) (parse-t #'t depth esc?)])
(values drivers guide))]))
;; lookup : Identifier Nat -> (U PVar Metafunction #f) ;; parse-t-nonpair : Stx Nat Boolean Boolean -> ...
(define (lookup id depth) ;; PRE: t is not a stxpair
(let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) (define (parse-t-nonpair t depth esc? in-try?)
(template-metafunction? v))))]) (syntax-case t (?? ?@ unsyntax quasitemplate)
(cond [(syntax-pattern-variable? v) [id
(let* ([pvar-depth (syntax-mapping-depth v)] (identifier? #'id)
[attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] (cond [(or (and (not esc?)
[attr (and (attribute-mapping? attr) attr)]) (or (free-identifier=? #'id (quote-syntax ...))
(cond [(not depth) ;; not looking for pvars, only for metafuns (free-identifier=? #'id (quote-syntax ??))
#f] (free-identifier=? #'id (quote-syntax ?@))))
[(zero? pvar-depth) (and (quasi)
(pvar v attr #f)] (or (free-identifier=? #'id (quote-syntax unsyntax))
[(>= depth pvar-depth) (free-identifier=? #'id (quote-syntax unsyntax-splicing)))))
(pvar v attr (- depth pvar-depth))] (wrong-syntax #'id "illegal use")]
[else [(lookup-metafun #'id)
(wrong-syntax id "missing ellipses with pattern variable in template")]))] (wrong-syntax t "illegal use of syntax metafunction")]
[(template-metafunction? v) [(lookup #'id depth)
v] => (lambda (pvar) (values (dset pvar) `(t-var ,pvar ,in-try?)))]
[else [else (values (dset) const-guide)])]
;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute [vec
(for ([pfx (in-list (dotted-prefixes id))]) (vector? (syntax-e #'vec))
(let ([pfx-v (syntax-local-value pfx (lambda () #f))]) (let-values ([(drivers guide)
(when (and (syntax-pattern-variable? pfx-v) (parse-t (vector->list (syntax-e #'vec)) depth esc? in-try?)])
(let ([valvar (syntax-mapping-valvar pfx-v)]) (values drivers (if (const-guide? guide) const-guide `(t-vector ,guide))))]
(attribute-mapping? (syntax-local-value valvar (lambda () #f))))) [pstruct
(wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) (prefab-struct-key (syntax-e #'pstruct))
#f]))) (let-values ([(drivers guide)
(let ([elems (cdr (vector->list (struct->vector (syntax-e #'pstruct))))])
(parse-t elems depth esc? in-try?))])
(values drivers (if (const-guide? guide) const-guide `(t-struct ,guide))))]
[#&template
(let-values ([(drivers guide)
(parse-t #'template depth esc? in-try?)])
(values drivers (if (const-guide? guide) const-guide `(t-box ,guide))))]
[const
(values (dset) const-guide)]))
;; parse-h : Syntax Nat Boolean Boolean -> (values (dsetof PVar) HeadGuide)
(define (parse-h h depth esc? in-try?)
(syntax-case h (?? ?@ unsyntax-splicing)
[(?? t)
(not esc?)
(let-values ([(drivers guide) (parse-h #'t depth esc? #t)])
(values drivers `(h-orelse ,guide #f)))]
[(?? t1 t2)
(not esc?)
(let-values ([(drivers1 guide1) (parse-h #'t1 depth esc? #t)]
[(drivers2 guide2) (parse-h #'t2 depth esc? in-try?)])
(values (dset-union drivers1 drivers2)
(if (and (ht-guide? guide1) (ht-guide? guide2))
`(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2)))
`(h-orelse ,guide1 ,guide2))))]
[(?@ . _)
(not esc?)
(let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)])
(values drivers `(h-splice ,guide)))]
[(unsyntax-splicing t1)
(quasi)
(let ([qval (quasi)])
(cond [(box? qval)
(with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))])
(set-box! qval (cons (cons #'tmp h) (unbox qval)))
(values (dset) `(h-unsyntax-splicing ,#'tmp)))]
[else
(parameterize ((quasi (car qval)))
(let*-values ([(drivers guide) (parse-t #'t1 depth esc? in-try?)]
[(drivers guide) (values drivers (list-guide const-guide guide))])
(values drivers guide)))]))]
[t
(let-values ([(drivers guide) (parse-t #'t depth esc? in-try?)])
(values drivers `(h-t ,guide)))]))
;; lookup : Identifier Nat -> PVar/#f
(define (lookup id depth)
(let ([v (syntax-local-value/record id syntax-pattern-variable?)])
(cond [(syntax-pattern-variable? v)
(hash-ref! env (cons v depth)
(lambda ()
(define pvar-depth (syntax-mapping-depth v))
(define attr
(let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))])
(and (attribute-mapping? attr) attr)))
(define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v)))
(define check? (and attr (not (attribute-mapping-syntax? attr))))
(cond [(zero? pvar-depth)
(pvar var var check? #f)]
[(>= depth pvar-depth)
(define lvar (car (generate-temporaries #'(pv_))))
(pvar var lvar check? (- depth pvar-depth))]
[else
(wrong-syntax id "missing ellipses with pattern variable in template")])))]
[else
;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute
(for ([pfx (in-list (dotted-prefixes id))])
(let ([pfx-v (syntax-local-value pfx (lambda () #f))])
(when (and (syntax-pattern-variable? pfx-v)
(let ([valvar (syntax-mapping-valvar pfx-v)])
(attribute-mapping? (syntax-local-value valvar (lambda () #f)))))
(wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx)))))
#f])))
(let-values ([(drivers guide) (parse-t t 0 #f #f)])
(values (dset->list drivers) guide)))
;; lookup-metafun : Identifier -> Metafunction/#f
(define (lookup-metafun id)
(syntax-local-value/record id template-metafunction?))
(define (dotted-prefixes id) (define (dotted-prefixes id)
(let* ([id-string (symbol->string (syntax-e id))] (let* ([id-string (symbol->string (syntax-e id))]
@ -325,30 +346,18 @@
(define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...)))) (define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...))))
(define (cons-guide g1 g2) (define (cons-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons g1 g2))) (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons ,g1 ,g2)))
(define (cons/p-guide g1 g2) (define (cons/p-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons/p g1 g2))) (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/p ,g1 ,g2)))
(define (cons/x-guide g1 g2) (define (cons/x-guide g1 g2)
(if (and (eq? g1 '_) (eq? g2 '_)) '_ (vector 'cons/x g1 g2))) (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/x ,g1 ,g2)))
(define (list-guide . gs) (foldr cons-guide '_ gs)) (define (list-guide . gs) (foldr cons-guide const-guide gs))
(define (list/p-guide . gs) (foldr cons/p-guide '_ gs)) (define (list/p-guide . gs) (foldr cons/p-guide const-guide gs))
(define (list/x-guide . gs) (foldr cons/x-guide '_ gs)) (define (list/x-guide . gs) (foldr cons/x-guide const-guide gs))
(define ((pvar/dd<=? expected-dd) x) (define ((pvar/dd<=? expected-dd) x)
(match x (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd))))
[(pvar sm attr dd) (and dd (<= dd expected-dd))]
[_ #f]))
(define (pvar-var x)
(match x
[(pvar sm '#f dd) (syntax-mapping-valvar sm)]
[(pvar sm attr dd) (attribute-mapping-var attr)]))
(define (pvar-check? x)
(match x
[(pvar sm '#f dd) #f]
[(pvar sm attr dd) (not (attribute-mapping-syntax? attr))]))
(define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x)))
@ -361,151 +370,43 @@
;; (template/loc loc-stx pvar) => don't relocate ;; (template/loc loc-stx pvar) => don't relocate
;; relocate-guide : Guide Id -> Guide ;; relocate-guide : Guide Id -> Guide
(define (relocate-guide g0 loc-pvar) (define (relocate-guide g0 loc-id)
(define (relocate g) (define (relocate g) `(t-relocate ,g ,loc-id))
(vector 'relocate g loc-pvar))
(define (error/no-relocate) (define (error/no-relocate)
(wrong-syntax #f "cannot apply syntax location to template")) (wrong-syntax #f "cannot apply syntax location to template"))
(define (loop g) (define (loop g)
(match g (match g
['_ [(list 't-escaped g1)
(relocate g)] (list 't-escaped (loop g1))]
[(vector 'cons g1 g2) [(list 't-var pvar in-try?)
(relocate g)] ;; Ideally, should error. Don't relocate.
[(vector 'cons/x g1 g2)
(relocate g)]
[(? pvar? g)
g] g]
[(vector 'dots head new-hdrivers/level nesting tail) [(list 't-dots head new-hdrivers/level nesting tail cons? in-try?)
;; Ideally, should error. For perfect backwards compatability, ;; Ideally, should error. For perfect backwards compatability,
;; should relocate. But if there are zero iterations, that ;; should relocate. But if there are zero iterations, that
;; means we'd relocate tail (which might be bad). Making ;; means we'd relocate tail (which might be bad). Making
;; relocation depend on number of iterations would be ;; relocation depend on number of iterations would be
;; complicated. So just ignore. ;; complicated. So just ignore.
g] g]
[(vector 'escaped g1) [(list 't-unsyntax var)
(vector 'escaped (loop g1))]
[(vector 'vector g1)
(relocate g)]
[(vector 'struct g1)
(relocate g)]
[(vector 'box g1)
(relocate g)]
[(vector 'unsyntax var)
g] g]
;; ---- ;; ----
[(vector 'append/x ghead gtail) [(list 't-append/x ghead gtail)
(match ghead (match ghead
[(vector 'unsyntax-splicing _) g] [(list 'h-unsyntax-splicing _) g]
[_ (error/no-relocate)])] [_ (error/no-relocate)])]
;; ---- ;; ----
[(vector 'orelse g1 g2) [(cons kind _)
(error/no-relocate)] (cond [(memq kind '(t-const t-cons t-cons/x t-vector t-struct t-box))
[(vector 'orelse-h g1 g2) (relocate g)]
(error/no-relocate)] [else (error/no-relocate)])]))
[(vector 'metafun mf g1)
(error/no-relocate)]
[(vector 'orelse-h1 g1)
(error/no-relocate)]
[(vector 'splice g1)
(error/no-relocate)]
[(vector 'unsyntax-splicing var)
g]
[else (error 'template "internal error: bad guide for relocation: ~e" g0)]))
(loop g0)) (loop g0))
;; ---------------------------------------- ;; ----------------------------------------
;; Compilation ;; Compilation
;; compile-guide : guide hash[env-entry => identifier] -> syntax[expr] ;; compile-guide : Guide -> Syntax[Expr]
(define (compile-guide g env) (define (compile-guide g) (datum->syntax #'here g))
(define (lookup var) (hash-ref env var))
(define (compile-t g in-try?)
(define (loop g) (compile-t g in-try?))
(define (loop-h g) (compile-h g in-try?))
(match g
['_
#`(t-const)]
[(? pvar? pvar)
(if (pvar-check? pvar)
#`(t-check #,(lookup pvar) '#,in-try?)
#`(t-var #,(lookup pvar)))]
[(vector 'cons g1 g2)
#`(t-cons #,(loop g1) #,(loop g2))]
[(vector 'cons/p g1 g2)
#`(t-cons/p #,(loop g1) #,(loop g2))]
[(vector 'cons/x g1 g2)
#`(t-cons/x #,(loop g1) #,(loop g2))]
[(vector 'dots head new-driverss nesting tail)
(let ()
(define cons? (not (head-guide? head)))
;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
;; -> Syntax[(Listof AccElem) -> (Listof AccElem)]
(define (gen-level vars inner)
(with-syntax ([(var ...) (map lookup vars)]
[(var-value ...) (map var-value-expr vars)])
#`(lambda (acc)
(let loop ([acc acc] [var var-value] ...)
(check-same-length var ...)
(if (and (pair? var) ...)
(loop (let ([var (car var)] ...)
(#,inner acc)) ;; inner has free refs to {var ...}
(cdr var) ...)
acc)))))
;; var-value-expr : PVar -> Syntax[List]
(define (var-value-expr pvar)
(with-syntax ([var (lookup pvar)])
(if (pvar-check? pvar)
#`(check-list/depth stx var 1 '#,in-try?)
#'var)))
(define head-loop-code
(let nestloop ([new-driverss new-driverss] [old-drivers null])
(cond [(null? new-driverss)
(if cons?
#`(lambda (acc) (cons (#,(loop head) stx) acc))
#`(lambda (acc) (cons (#,(loop-h head) stx) acc)))]
[else
(define drivers (append (car new-driverss) old-drivers))
(gen-level drivers (nestloop (cdr new-driverss) drivers))])))
(if cons?
#`(t-dots1 (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail))
#`(t-dots (lambda (stx) (#,head-loop-code null)) '#,nesting #,(loop tail))))]
[(vector 'append/p head tail)
#`(t-append/p #,(loop-h head) #,(loop tail))]
[(vector 'append/x head tail)
#`(t-append/x #,(loop-h head) #,(loop tail))]
[(vector 'escaped g1)
#`(t-escaped #,(loop g1))]
[(vector 'orelse g1 g2)
#`(t-orelse #,(compile-t g1 #t) #,(loop g2))]
[(vector 'metafun mf g1)
#`(t-metafun #,(template-metafunction-var mf) #,(loop g1))]
[(vector 'vector g1)
#`(t-vector #,(loop g1))]
[(vector 'struct g1)
#`(t-struct #,(loop g1))]
[(vector 'box g1)
#`(t-box #,(loop g1))]
[(vector 'unsyntax var)
#`(t-unsyntax #,var)]
[(vector 'relocate g1 var)
#`(t-relocate #,(loop g1) #,var)]
[else (error 'template "internal error: bad guide: ~e" g)]))
(define (compile-h g in-try?)
(define (loop g) (compile-t g in-try?))
(define (loop-h g) (compile-h g in-try?))
(match g
[(vector 'orelse-h1 g1)
#`(t-orelse #,(compile-h g1 #t) #f)]
[(vector 'orelse-h g1 g2)
#`(t-orelse #,(compile-h g1 #t) #,(loop-h g2))]
[(vector 'splice g1)
#`(t-splice #,(loop g1))]
[(vector 'unsyntax-splicing var)
#`(t-unsyntax-splicing #,var)]
[else #`(t-h #,(loop g))]))
(compile-t g #f))
;; ---------------------------------------- ;; ----------------------------------------
@ -514,22 +415,18 @@
(with-disappeared-uses (with-disappeared-uses
(parameterize ((current-syntax-context ctx) (parameterize ((current-syntax-context ctx)
(quasi (and quasi? (box null)))) (quasi (and quasi? (box null))))
(define-values (drivers pre-guide) (parse-t tstx 0 #f)) (define-values (pvars pre-guide) (parse-template tstx))
(define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide)) (define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide))
(define pvars (dset->list drivers))
(define env
(for/fold ([env (hash)]) ([pvar (in-list pvars)])
(hash-set env pvar (car (generate-temporaries #'(pv_))))))
(syntax-arm (syntax-arm
(with-syntax ([t tstx] (with-syntax ([t tstx]
[((var . pvar-val-var) ...) [((var . pvar-val-var) ...)
(for/list ([pvar (in-list pvars)]) (for/list ([pvar (in-list pvars)] #:when (pvar-dd pvar))
(cons (hash-ref env pvar) (pvar-var pvar)))] (cons (pvar-lvar pvar) (pvar-var pvar)))]
[((un-var . un-form) ...) [((un-var . un-form) ...)
(if quasi? (reverse (unbox (quasi))) null)]) (if quasi? (reverse (unbox (quasi))) null)])
#`(let ([un-var (handle-unsyntax un-form)] ... [var pvar-val-var] ...) #`(let ([un-var (handle-unsyntax un-form)] ... [var pvar-val-var] ...)
(let ([tstx0 (quote-syntax t)]) (let ([tstx0 (quote-syntax t)])
(#,(compile-guide guide env) tstx0)))))))) (#,(compile-guide guide) tstx0))))))))
) )
(define-syntax (template stx) (define-syntax (template stx)
@ -604,6 +501,50 @@
;; Note: as an optimization, we track syntax vs non-syntax pairs in the template ;; Note: as an optimization, we track syntax vs non-syntax pairs in the template
;; so we can generate more specific code (hopefully smaller and faster). ;; so we can generate more specific code (hopefully smaller and faster).
(define-syntax (t-var stx)
(syntax-case stx ()
[(t-var #s(pvar var lvar check? _) in-try?)
(cond [(syntax-e #'check?)
#`(lambda (stx) (check-stx stx lvar in-try?))]
[else
#`(lambda (stx) lvar)])]))
(define-syntax (t-dots stx)
(syntax-case stx ()
[(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? ...) ...))])
;; AccElem = Stx if cons? is true, (Listof Stx) otherwise
;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)]
;; -> Syntax[(Listof AccElem) -> (Listof AccElem)]
(define (gen-level lvars check?s inner)
(with-syntax ([(lvar ...) lvars]
[(var-value ...) (map var-value-expr lvars check?s)])
#`(lambda (acc)
(let loop ([acc acc] [lvar var-value] ...)
(check-same-length lvar ...)
(if (and (pair? lvar) ...)
(loop (let ([lvar (car lvar)] ...)
(#,inner acc)) ;; inner has free refs to {var ...}
(cdr lvar) ...)
acc)))))
;; var-value-expr : Id Boolean -> Syntax[List]
(define (var-value-expr lvar check?)
(if check? #`(check-list/depth stx #,lvar 1 in-try?) lvar))
(define head-loop-code
(let nestloop ([lvarss lvarss] [check?ss check?ss] [old-lvars null] [old-check?s null])
(cond [(null? lvarss)
#'(lambda (acc) (cons (head stx) acc))]
[else
(define lvars* (append (car lvarss) old-lvars))
(define check?s* (append (car check?ss) old-check?s))
(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)))]))
(begin-encourage-inline (begin-encourage-inline
(define (stx-cadr x) (stx-car (stx-cdr x))) (define (stx-cadr x) (stx-car (stx-cdr x)))
@ -614,16 +555,14 @@
(if (syntax? basis) (datum->syntax basis val basis basis) val)) (if (syntax? basis) (datum->syntax basis val basis basis) val))
(define ((t-const) stx) stx) (define ((t-const) stx) stx)
(define ((t-var v) stx) v)
(define ((t-check v in-try?) stx) (check-stx stx v in-try?))
(define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx)))) (define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx))))
(define ((t-append/x h t) stx) (restx stx (append (h (car (syntax-e stx))) (t (cdr (syntax-e stx)))))) (define ((t-append/x h t) stx) (restx stx (append (h (car (syntax-e stx))) (t (cdr (syntax-e stx))))))
(define ((t-cons h t) stx) (restx stx (cons (h (stx-car stx)) (t (stx-cdr stx))))) (define ((t-cons h t) stx) (restx stx (cons (h (stx-car stx)) (t (stx-cdr stx)))))
(define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx)))) (define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx))))
(define ((t-cons/x h t) stx) (restx stx (cons (h (car (syntax-e stx))) (t (cdr (syntax-e stx)))))) (define ((t-cons/x h t) stx) (restx stx (cons (h (car (syntax-e stx))) (t (cdr (syntax-e stx))))))
(define ((t-dots h n t) stx) (define ((t-dots* h n t) stx)
(restx stx (revappend* (h (stx-car stx)) (t (stx-drop (add1 n) stx))))) (restx stx (revappend* (h (stx-car stx)) (t (stx-drop (add1 n) stx)))))
(define ((t-dots1 h n t) stx) (define ((t-dots1* h n t) stx)
(restx stx (revappend (h (stx-car stx)) (t (stx-drop (add1 n) stx))))) (restx stx (revappend (h (stx-car stx)) (t (stx-drop (add1 n) stx)))))
(define ((t-escaped g) stx) (g (stx-cadr stx))) (define ((t-escaped g) stx) (g (stx-cadr stx)))
(define ((t-orelse g1 g2) stx) (define ((t-orelse g1 g2) stx)
@ -636,12 +575,13 @@
(define key (prefab-struct-key s)) (define key (prefab-struct-key s))
(define elems (cdr (vector->list (struct->vector s)))) (define elems (cdr (vector->list (struct->vector s))))
(restx stx (apply make-prefab-struct key (g elems)))) (restx stx (apply make-prefab-struct key (g elems))))
(define ((t-h g) stx) (list (g stx))) (define ((h-t g) stx) (list (g stx)))
(define ((t-relocate g loc) stx) (define ((t-relocate g loc) stx)
(define new-stx (g stx)) (define new-stx (g stx))
(datum->syntax new-stx (syntax-e new-stx) loc new-stx)) (datum->syntax new-stx (syntax-e new-stx) loc new-stx))
(define ((t-unsyntax v) stx) (restx stx v)) (define ((t-unsyntax v) stx) (restx stx v))
(define ((t-unsyntax-splicing v) stx) (stx->list v)) (define ((h-unsyntax-splicing v) stx) (stx->list v))
(define (h-orelse g1 g2) (t-orelse g1 g2))
#| end begin-encourage-inline |#) #| end begin-encourage-inline |#)
(define ((t-metafun mf g) stx) (define ((t-metafun mf g) stx)
@ -654,7 +594,7 @@
(unless (syntax? r) (unless (syntax? r)
(raise-syntax-error #f "result of template metafunction was not syntax" stx)) (raise-syntax-error #f "result of template metafunction was not syntax" stx))
(old-mark (mark r)))) (old-mark (mark r))))
(define ((t-splice g) stx) (define ((h-splice g) stx)
(let ([r (g (stx-cdr stx))]) (let ([r (g (stx-cdr stx))])
(or (stx->list r) (or (stx->list r)
(raise-syntax-error 'template "splicing template did not produce a syntax list" stx)))) (raise-syntax-error 'template "splicing template did not produce a syntax list" stx))))