syntax/parse: added template metafunctions
Also fixed some bugs and added simple optimizations.
This commit is contained in:
Ryan Culpepper
parent
7882dadc3a
commit
5a1badf397
|
|
@ -11,6 +11,7 @@
|
|||
syntax/parse/private/residual
|
||||
unstable/struct)
|
||||
(provide template
|
||||
define-template-metafunction
|
||||
??
|
||||
?@)
|
||||
|
||||
|
|
@ -27,6 +28,7 @@ To do:
|
|||
A Template (T) is one of:
|
||||
- pvar
|
||||
- atom (including (), not pvar)
|
||||
- (metafunction . T)
|
||||
- (H . T)
|
||||
- (H ... . T), (H ... ... . T), etc
|
||||
- (?? T T)
|
||||
|
|
@ -42,18 +44,32 @@ A HeadTemplate (H) is one of:
|
|||
(parameterize ((current-syntax-context stx))
|
||||
(syntax-case stx ()
|
||||
[(template t)
|
||||
(let-values ([(guide pvars) (parse-template #'t)])
|
||||
(let-values ([(guide deps) (parse-template #'t)])
|
||||
;; (eprintf "guide = ~s\n" guide)
|
||||
(with-syntax ([guide
|
||||
guide]
|
||||
[(var ...)
|
||||
(for/list ([pvar (in-vector pvars)])
|
||||
(let* ([valvar (syntax-mapping-valvar pvar)]
|
||||
[attr (syntax-local-value valvar (lambda () #f))])
|
||||
(cond [(attribute-mapping? attr)
|
||||
(attribute-mapping-var attr)]
|
||||
[else valvar])))])
|
||||
(syntax-arm #'(substitute (quote-syntax t) 'guide (vector var ...)))))])))
|
||||
(let ([vars
|
||||
(for/list ([dep (in-vector deps)])
|
||||
(cond [(syntax-pattern-variable? dep)
|
||||
(let* ([valvar (syntax-mapping-valvar dep)]
|
||||
[attr (syntax-local-value valvar (lambda () #f))])
|
||||
(cond [(attribute-mapping? attr)
|
||||
(attribute-mapping-var attr)]
|
||||
[else valvar]))]
|
||||
[(template-metafunction? dep)
|
||||
(template-metafunction-var dep)]))])
|
||||
(syntax-arm
|
||||
(cond [(equal? guide '1) ;; was (template pvar)
|
||||
(with-syntax ([var (car vars)])
|
||||
#'(if (syntax? var)
|
||||
var
|
||||
(error/not-stx (quote-syntax t) var)))]
|
||||
[(equal? guide '_) ;; constant
|
||||
#`(quote-syntax t)]
|
||||
[else
|
||||
(with-syntax ([guide guide]
|
||||
[(var ...) vars])
|
||||
#'(substitute (quote-syntax t)
|
||||
'guide
|
||||
(vector var ...)))]))))])))
|
||||
|
||||
(define-syntaxes (?? ?@)
|
||||
(let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))])
|
||||
|
|
@ -65,8 +81,7 @@ A HeadTemplate (H) is one of:
|
|||
A Guide (G) is one of:
|
||||
- _
|
||||
- (G . G)
|
||||
- positive-integer
|
||||
- negative-integer
|
||||
- integer
|
||||
- #s(stxvector G)
|
||||
- #s(stxstruct G)
|
||||
- #&G
|
||||
|
|
@ -74,11 +89,17 @@ A Guide (G) is one of:
|
|||
- #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:
|
||||
- G
|
||||
- #s(app-opt G (vector-of integer))
|
||||
- #s(splice G)
|
||||
|
||||
A Pre-Guide is like a Guide but with pvars and pvar sets instead of
|
||||
integers and integer vectors.
|
||||
|#
|
||||
|
||||
(define-syntax-rule (begin-both-phases form ...)
|
||||
|
|
@ -92,8 +113,31 @@ A HeadGuide (HG) is one of:
|
|||
(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 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)
|
||||
(syntax-case stx ()
|
||||
[(dsm (id arg ...) . body)
|
||||
#'(dsm id (lambda (arg ...) . body))]
|
||||
[(dsm id expr)
|
||||
(identifier? #'id)
|
||||
(with-syntax ([(internal-id) (generate-temporaries #'(id))])
|
||||
#'(begin (define internal-id expr)
|
||||
(define-syntax id
|
||||
(template-metafunction (quote-syntax internal-id)))))]))
|
||||
|
||||
(begin-for-syntax
|
||||
(struct template-metafunction (var)))
|
||||
|
||||
;; ============================================================
|
||||
|
||||
|
|
@ -101,29 +145,37 @@ A HeadGuide (HG) is one of:
|
|||
|
||||
(define (parse-template t)
|
||||
(let-values ([(_const? drivers pre-guide) (parse-t t 0 #f)])
|
||||
;; (eprintf "pre-guide = ~s\n" pre-guide)
|
||||
(define (pvar-set->env drivers)
|
||||
(define (set->env drivers)
|
||||
(for/hash ([pvar (in-set drivers)]
|
||||
[n (in-naturals 1)])
|
||||
(values pvar n)))
|
||||
(define main-env (pvar-set->env drivers))
|
||||
(define main-env (set->env drivers))
|
||||
(define (loop g loop-env)
|
||||
(define (pvar->index pvar)
|
||||
(let ([loop-index (hash-ref loop-env pvar #f)])
|
||||
(define (get-index x)
|
||||
(let ([loop-index (hash-ref loop-env x #f)])
|
||||
(if loop-index
|
||||
(- loop-index)
|
||||
(hash-ref main-env pvar))))
|
||||
(hash-ref main-env x))))
|
||||
(match g
|
||||
['_ '_]
|
||||
[(cons g1 g2) (cons (loop g1 loop-env) (loop g2 loop-env))]
|
||||
[(? syntax-pattern-variable? pvar) (pvar->index pvar)]
|
||||
[(? syntax-pattern-variable? pvar) (get-index pvar)]
|
||||
[(dots head hdrivers nesting tail)
|
||||
(let* ([sub-loop-env (pvar-set->env hdrivers)]
|
||||
[sub-loop-vector (index-hash->vector sub-loop-env pvar->index)])
|
||||
(dots (loop head sub-loop-env)
|
||||
sub-loop-vector
|
||||
nesting
|
||||
(loop tail loop-env)))]
|
||||
(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)
|
||||
|
|
@ -131,8 +183,11 @@ A HeadGuide (HG) is one of:
|
|||
[(orelse g1 drivers1 g2)
|
||||
(orelse (loop g1 loop-env)
|
||||
(for/vector ([pvar (in-set drivers1)])
|
||||
(pvar->index pvar))
|
||||
(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)
|
||||
|
|
@ -142,10 +197,10 @@ A HeadGuide (HG) is one of:
|
|||
[(app-opt g1 drivers1)
|
||||
(app-opt (loop g1 loop-env)
|
||||
(for/vector ([pvar (in-set drivers1)])
|
||||
(pvar->index pvar)))]
|
||||
(get-index pvar)))]
|
||||
[(splice g1)
|
||||
(splice (loop g1 loop-env))]
|
||||
[else (error 'parse:convert "bad pre-guide: ~e" g)]))
|
||||
[else (error 'template "internal error: bad pre-guide: ~e" g)]))
|
||||
(define guide (loop pre-guide #hash()))
|
||||
(values guide
|
||||
(index-hash->vector main-env))))
|
||||
|
|
@ -162,12 +217,36 @@ A HeadGuide (HG) is one of:
|
|||
(free-identifier=? #'id (quote-syntax ?@))))
|
||||
(wrong-syntax #'id "illegal use")]
|
||||
[else
|
||||
(let ([pvar (lookup-pvar #'id depth)])
|
||||
(cond [pvar (values #f (set pvar) pvar)]
|
||||
(let ([pvar (lookup #'id depth)])
|
||||
(cond [(syntax-pattern-variable? pvar)
|
||||
(values #f (set pvar) pvar)]
|
||||
[(template-metafunction? pvar)
|
||||
(wrong-syntax t "illegal use of syntax metafunction")]
|
||||
[else (values #t (set) '_)]))])]
|
||||
[atom
|
||||
(atom? (syntax-e #'atom))
|
||||
(values #t (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?)])
|
||||
(values #f
|
||||
(set-union (set mf) drivers)
|
||||
(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)])
|
||||
(values #f drivers (escaped guide)))]
|
||||
[(?? t1 t2)
|
||||
(not esc?)
|
||||
(let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)]
|
||||
[(const2? drivers2 guide2) (parse-t #'t2 depth esc?)])
|
||||
(values #f
|
||||
(set-union drivers1 drivers2)
|
||||
(orelse guide1 (set-filter drivers1 syntax-pattern-variable?) guide2)))]
|
||||
[(head DOTS . tail)
|
||||
(and (not esc?)
|
||||
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
|
||||
|
|
@ -180,24 +259,11 @@ A HeadGuide (HG) is one of:
|
|||
[else (values nesting tail)]))])
|
||||
(let-values ([(hconst? hdrivers _hsplice? hguide) (parse-h #'head (+ depth nesting) esc?)]
|
||||
[(tconst? tdrivers tguide) (parse-t tail depth esc?)])
|
||||
(unless (positive? (set-count hdrivers))
|
||||
(wrong-syntax #'head "no pattern variables in term before ellipsis"))
|
||||
(values #f
|
||||
(set-union hdrivers tdrivers)
|
||||
(dots hguide hdrivers nesting tguide))))]
|
||||
[(DOTS template)
|
||||
(and (not esc?)
|
||||
(identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...)))
|
||||
(let-values ([(const? drivers guide) (parse-t #'template depth #t)])
|
||||
(values #f drivers (escaped guide)))]
|
||||
[(?? t1 t2)
|
||||
(not esc?)
|
||||
(let-values ([(const1? drivers1 guide1) (parse-t #'t1 depth esc?)]
|
||||
[(const2? drivers2 guide2) (parse-t #'t2 depth esc?)])
|
||||
(values #f
|
||||
(set-union drivers1 drivers2)
|
||||
(orelse guide1 drivers1 guide2)))]
|
||||
[(?? . _)
|
||||
(not esc?)
|
||||
(wrong-syntax t "bad pattern")]
|
||||
(dots hguide (set-filter hdrivers pvar/depth>0?) nesting tguide))))]
|
||||
[(head . tail)
|
||||
(let-values ([(hconst? hdrivers hsplice? hguide) (parse-h #'head depth esc?)]
|
||||
[(tconst? tdrivers tguide) (parse-t #'tail depth esc?)])
|
||||
|
|
@ -225,7 +291,7 @@ A HeadGuide (HG) is one of:
|
|||
[(?? t)
|
||||
(not esc?)
|
||||
(let-values ([(const? drivers guide) (parse-t #'t depth esc?)])
|
||||
(values #f drivers #t (app-opt guide drivers)))]
|
||||
(values #f drivers #t (app-opt guide (set-filter drivers syntax-pattern-variable?))))]
|
||||
[(?@ . t)
|
||||
(not esc?)
|
||||
(let-values ([(const? drivers guide) (parse-t #'t depth esc?)])
|
||||
|
|
@ -244,16 +310,23 @@ A HeadGuide (HG) is one of:
|
|||
(regexp? x)
|
||||
(char? x)))
|
||||
|
||||
(define (lookup-pvar id depth)
|
||||
;; Note: always creates equal?-based set.
|
||||
(define (set-filter s pred?)
|
||||
(for/set ([el (in-set s)] #:when (pred? el)) el))
|
||||
|
||||
(define (lookup id depth)
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(cond [(syntax-pattern-variable? v)
|
||||
(unless (or (= (syntax-mapping-depth v) depth)
|
||||
(unless (or (not depth)
|
||||
(= (syntax-mapping-depth v) depth)
|
||||
(= (syntax-mapping-depth v) 0))
|
||||
(wrong-syntax id
|
||||
"pattern variable used at wrong ellipsis depth (expected ~s, used at ~s)"
|
||||
(syntax-mapping-depth v)
|
||||
depth))
|
||||
v]
|
||||
[(template-metafunction? v)
|
||||
v]
|
||||
[else #f])))
|
||||
|
||||
(define (index-hash->vector hash [f values])
|
||||
|
|
@ -261,17 +334,22 @@ A HeadGuide (HG) is one of:
|
|||
(for ([(value index) (in-hash hash)])
|
||||
(vector-set! vec (sub1 index) (f value)))
|
||||
vec))
|
||||
|
||||
(define (pvar/depth>0? x)
|
||||
(and (syntax-pattern-variable? x)
|
||||
(positive? (syntax-mapping-depth x))))
|
||||
|
||||
)
|
||||
|
||||
;; ============================================================
|
||||
|
||||
(define (substitute stx g main-env)
|
||||
;; (eprintf "main-env = ~s\n" main-env)
|
||||
(define (get index lenv)
|
||||
(cond [(positive? index)
|
||||
(vector-ref main-env (sub1 index))]
|
||||
[else
|
||||
(vector-ref lenv (- -1 index))]))
|
||||
[(negative? index)
|
||||
(vector-ref lenv (- -1 index))]
|
||||
[(zero? index) lenv]))
|
||||
(define (loop stx g lenv)
|
||||
(match g
|
||||
['_ stx]
|
||||
|
|
@ -279,9 +357,21 @@ A HeadGuide (HG) is one of:
|
|||
(restx stx (cons (loop (stx-car stx) g1 lenv) (loop (stx-cdr stx) g2 lenv)))]
|
||||
[(? exact-integer? index)
|
||||
(let ([v (get index lenv)])
|
||||
(unless (syntax? v)
|
||||
(error 'template "syntax pattern variable is not syntax-valued"))
|
||||
v)]
|
||||
(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)
|
||||
|
|
@ -289,11 +379,13 @@ A HeadGuide (HG) is one of:
|
|||
(loop-h head-stx ghead lenv*)]
|
||||
[else
|
||||
(for ([v (in-vector lenv*)])
|
||||
(unless v (error 'template "loop variable is not defined")))
|
||||
(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))
|
||||
(error 'template "loop variable count mismatch")))
|
||||
(raise-syntax-error 'template
|
||||
"incomplatible ellipsis match counts for template"
|
||||
stx)))
|
||||
(let dotsloop ([len0 len0] [lenv* lenv*])
|
||||
(if (zero? len0)
|
||||
null
|
||||
|
|
@ -313,6 +405,16 @@ A HeadGuide (HG) is one of:
|
|||
(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)
|
||||
|
|
@ -332,11 +434,20 @@ A HeadGuide (HG) is one of:
|
|||
(let* ([v (loop (stx-cdr stx) g1 lenv)]
|
||||
[v* (stx->list v)])
|
||||
(unless v*
|
||||
(error 'template "not a syntax list: ~e" 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))))
|
||||
|
|
@ -357,3 +468,6 @@ A HeadGuide (HG) is one of:
|
|||
[(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))
|
||||
|
|
|
|||
|
|
@ -278,6 +278,7 @@ patterns as @racket[target-stxclass-id] but with the given
|
|||
atomic-tmpl
|
||||
(head-tmpl . tmpl)
|
||||
(head-tmpl ellipsis ...+ . tmpl)
|
||||
(metafunction-id . tmpl)
|
||||
(?? tmpl tmpl)
|
||||
#(@#,svar[tmpl] ...)
|
||||
#s(prefab-struct-key @#,svar[tmpl] ...)
|
||||
|
|
@ -348,6 +349,13 @@ template:
|
|||
(template ((?@ . x) ...)))
|
||||
]
|
||||
}
|
||||
|
||||
@specsubform[(metafunction-id . tmpl)]{
|
||||
|
||||
Applies the template metafunction named @racket[metafunction-id] to
|
||||
the result of the template (including @racket[metafunction-id]
|
||||
itself). See @racket[define-template-metafunction] for examples.
|
||||
}
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
|
|
@ -356,3 +364,27 @@ template:
|
|||
]]{
|
||||
Auxiliary forms used by @racket[template].
|
||||
}
|
||||
|
||||
@defform*[[(define-template-metafunction metafunction-id expr)
|
||||
(define-template-metafunction (metafunction-id . formals) body ...+)]]{
|
||||
|
||||
Defines @racket[metafunction-id] as a @deftech{template metafunction}. A
|
||||
metafunction application in a @racket[template] expression (but not a
|
||||
@racket[syntax] expression) is evaluated by applying the metafunction
|
||||
to the result of processing the ``argument'' part of the template.
|
||||
|
||||
@examples[#:eval the-eval
|
||||
(define-template-metafunction (join stx)
|
||||
(syntax-parse stx
|
||||
[(join a:id b:id ...)
|
||||
(datum->syntax #'a
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map symbol->string
|
||||
(syntax->datum #'(a b ...)))))
|
||||
stx)]))
|
||||
(template (join a b c))
|
||||
(with-syntax ([(x ...) #'(a b c)])
|
||||
(template ((x (join tmp- x)) ...)))
|
||||
]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
;; Common pattern variable definitions
|
||||
;; (avoids having to have 'with-syntax' in every test case)
|
||||
|
||||
(define/with-syntax uu #'ABC)
|
||||
(define/with-syntax uu #'abc)
|
||||
(define/with-syntax (aa ...) #'(a b c))
|
||||
(define/with-syntax (xx ...) #'(x y z))
|
||||
(define/with-syntax (nn ...) #'(1 2 3))
|
||||
|
|
@ -30,7 +30,7 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(tc (template uu) 'ABC)
|
||||
(tc (template uu) 'abc)
|
||||
|
||||
;; FIXME: add other atoms when supported
|
||||
;; FIXME: add other compound stx when supported
|
||||
|
|
@ -39,7 +39,7 @@
|
|||
(tc (template 5) '5)
|
||||
(tc (template (1 2 #f #t "hey")) '(1 2 #f #t "hey"))
|
||||
(tc (template (1 . b)) '(1 . b))
|
||||
(tc (template (1 . uu)) '(1 . ABC))
|
||||
(tc (template (1 . uu)) '(1 . abc))
|
||||
|
||||
(tc (template #(aa ... done))
|
||||
'#(a b c done))
|
||||
|
|
@ -48,6 +48,8 @@
|
|||
|
||||
(tc (template (aa ...))
|
||||
'(a b c))
|
||||
(tc (template ((uu aa) ...))
|
||||
'((abc a) (abc b) (abc c)))
|
||||
(tc (template ((aa aa) ...))
|
||||
'((a a) (b b) (c c)))
|
||||
(tc (template (start (aa ok) ... done))
|
||||
|
|
@ -101,3 +103,25 @@
|
|||
[(a:id ... (~optional s:str) n:nat ...)
|
||||
(template (a ... n ... (?@ . (?? (string: s) ()))))])
|
||||
'(a b c 1 2 3 string: "hello!"))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
||||
(define-template-metafunction (join stx)
|
||||
(syntax-parse stx
|
||||
[(join a:id b:id ...)
|
||||
(datum->syntax #'a
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map symbol->string
|
||||
(syntax->datum #'(a b ...)))))
|
||||
stx)]))
|
||||
|
||||
(tc (template (join a b c))
|
||||
'abc)
|
||||
(tc (template ((xx (join tmp- xx)) ...))
|
||||
'((x tmp-x) (y tmp-y) (z tmp-z)))
|
||||
(tc (template ((xx (join uu - xx)) ...))
|
||||
'((x abc-x) (y abc-y) (z abc-z)))
|
||||
(tc (template ((xx (join aa xx)) ...))
|
||||
'((x ax) (y by) (z cz)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user