1139 lines
48 KiB
Racket
1139 lines
48 KiB
Racket
#lang racket
|
|
(require subtemplate/private/template-subscripts
|
|
stxparse-info/parse
|
|
stxparse-info/parse/experimental/template
|
|
stxparse-info/case
|
|
phc-toolkit/untyped
|
|
rackunit
|
|
syntax/macro-testing)
|
|
|
|
#|
|
|
(define-syntax (tst stx)
|
|
(syntax-case stx ()
|
|
[(_ tt)
|
|
#`'#,(find-subscript-binder #'tt #f)]))
|
|
|
|
(check-false (syntax-case #'(a b) ()
|
|
[(_ x)
|
|
(tst x)]))
|
|
|
|
(check-equal? (syntax-parse
|
|
#'(a b c)
|
|
[(_ x yᵢ)
|
|
(list (tst x)
|
|
(tst wᵢ))])
|
|
'(#f yᵢ))
|
|
|
|
|#
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate foo)]))
|
|
'foo)
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate foo)]))
|
|
'foo)
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate xⱼ)]))
|
|
'b)
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate xⱼ)]))
|
|
'b)
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (zᵢ …))]))
|
|
'(c d))
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (zᵢ …))]))
|
|
'(c d))
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (wᵢ …))]))
|
|
'(c/w d/w))
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (wᵢ …))]))
|
|
'(c/w d/w))
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (kⱼ wᵢ …))]))
|
|
'(b/k c/w d/w))
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (kⱼ wᵢ …))]))
|
|
'(b/k c/w d/w))
|
|
|
|
(check-equal? (syntax->datum (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (xⱼ kⱼ (zᵢ wᵢ) …))]))
|
|
'(b b/k (c c/w) (d d/w)))
|
|
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c d) ()
|
|
[(_ xⱼ zᵢ …)
|
|
(subtemplate (xⱼ kⱼ (wᵢ zᵢ) …))]))
|
|
'(b b/k (c/w c) (d/w d)))
|
|
|
|
;; With yᵢ appearing twice:
|
|
(check-equal? (syntax->datum (syntax-case #'(a b c) ()
|
|
[(xᵢ …)
|
|
(subtemplate (yᵢ … yᵢ …))]))
|
|
'(a/y b/y c/y a/y b/y c/y))
|
|
|
|
|
|
|
|
|
|
(let ()
|
|
(syntax-parse (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
|
|
(subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
|
|
[(([x1 w1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'x2)]))
|
|
|
|
(syntax-parse (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
|
|
(subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
|
|
[(([x1 w1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'x2)
|
|
(check bound-identifier=? #'w1 #'w2)
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)
|
|
|
|
(check bound-identifier=? #'x1 #'b)
|
|
(check bound-identifier=? #'z1 #'c)
|
|
(check bound-identifier=? #'zz1 #'d)
|
|
|
|
(check bound-identifier=? #'x2 #'b)
|
|
(check bound-identifier=? #'z2 #'c)
|
|
(check bound-identifier=? #'zz2 #'d)
|
|
|
|
;; The *1 are all different:
|
|
(check bound-identifier=? #'x1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'w1 #'x1)
|
|
(check bound-identifier=? #'w1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'foo1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'foo1 #'w1)
|
|
(check bound-identifier=? #'foo1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'foo1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'foo1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'foo1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'foo1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'z1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'z1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'z1 #'foo1)
|
|
(check bound-identifier=? #'z1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'z1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'z1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'z1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'p1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'z1)
|
|
(check bound-identifier=? #'p1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'zz1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'zz1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'zz1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'zz1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'zz1 #'p1)
|
|
(check bound-identifier=? #'zz1 #'zz1)
|
|
(check (∘ not bound-identifier=?) #'zz1 #'pp1)
|
|
|
|
(check (∘ not bound-identifier=?) #'pp1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'pp1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'pp1 #'foo1)
|
|
(check (∘ not bound-identifier=?) #'pp1 #'z1)
|
|
(check (∘ not bound-identifier=?) #'pp1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'pp1 #'zz1)
|
|
(check bound-identifier=? #'pp1 #'pp1)
|
|
|
|
;; The *2 are all different:
|
|
(check bound-identifier=? #'x2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'x2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'w2 #'x2)
|
|
(check bound-identifier=? #'w2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'w2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'w2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'w2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'w2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'w2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'foo2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'foo2 #'w2)
|
|
(check bound-identifier=? #'foo2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'foo2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'foo2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'foo2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'foo2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'z2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'z2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'z2 #'foo2)
|
|
(check bound-identifier=? #'z2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'z2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'z2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'z2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'p2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'p2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'p2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'p2 #'z2)
|
|
(check bound-identifier=? #'p2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'p2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'p2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'zz2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'zz2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'zz2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'zz2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'zz2 #'p2)
|
|
(check bound-identifier=? #'zz2 #'zz2)
|
|
(check (∘ not bound-identifier=?) #'zz2 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'pp2 #'x2)
|
|
(check (∘ not bound-identifier=?) #'pp2 #'w2)
|
|
(check (∘ not bound-identifier=?) #'pp2 #'foo2)
|
|
(check (∘ not bound-identifier=?) #'pp2 #'z2)
|
|
(check (∘ not bound-identifier=?) #'pp2 #'p2)
|
|
(check (∘ not bound-identifier=?) #'pp2 #'zz2)
|
|
(check bound-identifier=? #'pp2 #'pp2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(define flob (quasisubtemplate (zᵢ …)))
|
|
(quasisubtemplate (yᵢ …
|
|
#,flob
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
#,(quasisubtemplate (zᵢ …))
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
|
|
(quasisubtemplate (yᵢ …
|
|
#,flob
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
#,(syntax-parse #'d
|
|
[d (quasisubtemplate (zᵢ …))])
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
#,(syntax-parse #'d
|
|
[d (quasisubtemplate (zᵢ …))])
|
|
#,(syntax-parse #'d
|
|
[d (quasisubtemplate (zᵢ …))])
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
|
|
(check bound-identifier=? #'a3 #'a4)
|
|
(check bound-identifier=? #'b3 #'b4)
|
|
(check bound-identifier=? #'c3 #'c4)
|
|
|
|
(check bound-identifier=? #'a2 #'a4)
|
|
(check bound-identifier=? #'b2 #'b4)
|
|
(check bound-identifier=? #'c2 #'c4)
|
|
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
#,(syntax-parse #'d
|
|
[d (quasisubtemplate (kᵢ …))])
|
|
#,(syntax-parse #'d
|
|
[d (quasisubtemplate (kᵢ …))])
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) (a3 b3 c3) a4 b4 c4)
|
|
(check bound-identifier=? #'a2 #'a3)
|
|
(check bound-identifier=? #'b2 #'b3)
|
|
(check bound-identifier=? #'c2 #'c3)
|
|
|
|
(check (∘ not bound-identifier=?) #'a1 #'a2)
|
|
(check (∘ not bound-identifier=?) #'b1 #'b2)
|
|
(check (∘ not bound-identifier=?) #'c1 #'c2)
|
|
|
|
(check (∘ not bound-identifier=?) #'a2 #'a4)
|
|
(check (∘ not bound-identifier=?) #'b2 #'b4)
|
|
(check (∘ not bound-identifier=?) #'c2 #'c4)
|
|
|
|
(check (∘ not bound-identifier=?) #'a3 #'a4)
|
|
(check (∘ not bound-identifier=?) #'b3 #'b4)
|
|
(check (∘ not bound-identifier=?) #'c3 #'c4)])
|
|
|
|
;; Incompatible ellipsis counts
|
|
(begin
|
|
(check-exn #rx"incompatible ellipsis match counts for subscripted variables"
|
|
(λ ()
|
|
(syntax-case #'([a b c] [d]) ()
|
|
[([xᵢ …] [pᵢ …])
|
|
(quasisubtemplate ([xᵢ …] [pᵢ …] [zᵢ …]))])))
|
|
|
|
(check-equal? (syntax->datum
|
|
(syntax-case #'([a b c] [d]) ()
|
|
[([xᵢ …] [pᵢ …])
|
|
(quasisubtemplate ([xᵢ …] [pᵢ …]))]))
|
|
'([a b c] [d]))
|
|
|
|
(require (submod "../private/template-subscripts.rkt" test-private))
|
|
(check-exn #rx"incompatible ellipsis match counts for subscripted variables"
|
|
(λ ()
|
|
(generate-nested-ids 1
|
|
#'a
|
|
#'b
|
|
(λ (x) "fmt")
|
|
'((foo bar) (baz))
|
|
(list #'x #'y)
|
|
#'(whole))))
|
|
(check-equal? (map syntax-e
|
|
(generate-nested-ids 1
|
|
#'a
|
|
#'b
|
|
(λ (x) "fmt")
|
|
'((foo bar) (baz quux))
|
|
(list #'x #'y)
|
|
#'(whole)))
|
|
'(fmt fmt)))
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
#,(syntax-parse #'d
|
|
[zᵢ (quasisubtemplate (zᵢ))])
|
|
#,(syntax-parse #'d
|
|
[zᵢ (quasisubtemplate (zᵢ))])
|
|
zᵢ …))])
|
|
[(y yy yyy (d1) (d2) z zz zzz)
|
|
(check bound-identifier=? #'d1 #'d2)
|
|
|
|
(check (∘ not bound-identifier=?) #'y #'yy)
|
|
(check (∘ not bound-identifier=?) #'y #'yyy)
|
|
(check (∘ not bound-identifier=?) #'y #'d1)
|
|
(check (∘ not bound-identifier=?) #'y #'d2)
|
|
(check (∘ not bound-identifier=?) #'y #'z)
|
|
(check (∘ not bound-identifier=?) #'y #'zz)
|
|
(check (∘ not bound-identifier=?) #'y #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'yy #'y)
|
|
(check (∘ not bound-identifier=?) #'yy #'yyy)
|
|
(check (∘ not bound-identifier=?) #'yy #'d1)
|
|
(check (∘ not bound-identifier=?) #'yy #'d2)
|
|
(check (∘ not bound-identifier=?) #'yy #'z)
|
|
(check (∘ not bound-identifier=?) #'yy #'zz)
|
|
(check (∘ not bound-identifier=?) #'yy #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'yyy #'y)
|
|
(check (∘ not bound-identifier=?) #'yyy #'yy)
|
|
(check (∘ not bound-identifier=?) #'yyy #'d1)
|
|
(check (∘ not bound-identifier=?) #'yyy #'d2)
|
|
(check (∘ not bound-identifier=?) #'yyy #'z)
|
|
(check (∘ not bound-identifier=?) #'yyy #'zz)
|
|
(check (∘ not bound-identifier=?) #'yyy #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'d1 #'y)
|
|
(check (∘ not bound-identifier=?) #'d1 #'yy)
|
|
(check (∘ not bound-identifier=?) #'d1 #'yyy)
|
|
;(check (∘ not bound-identifier=?) #'d1 #'d2)
|
|
(check (∘ not bound-identifier=?) #'d1 #'z)
|
|
(check (∘ not bound-identifier=?) #'d1 #'zz)
|
|
(check (∘ not bound-identifier=?) #'d1 #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'d2 #'y)
|
|
(check (∘ not bound-identifier=?) #'d2 #'yy)
|
|
(check (∘ not bound-identifier=?) #'d2 #'yyy)
|
|
;(check (∘ not bound-identifier=?) #'d2 #'d1)
|
|
(check (∘ not bound-identifier=?) #'d2 #'z)
|
|
(check (∘ not bound-identifier=?) #'d2 #'zz)
|
|
(check (∘ not bound-identifier=?) #'d2 #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'z #'y)
|
|
(check (∘ not bound-identifier=?) #'z #'yy)
|
|
(check (∘ not bound-identifier=?) #'z #'yyy)
|
|
(check (∘ not bound-identifier=?) #'z #'d1)
|
|
(check (∘ not bound-identifier=?) #'z #'d2)
|
|
(check (∘ not bound-identifier=?) #'z #'zz)
|
|
(check (∘ not bound-identifier=?) #'z #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'zz #'y)
|
|
(check (∘ not bound-identifier=?) #'zz #'yy)
|
|
(check (∘ not bound-identifier=?) #'zz #'yyy)
|
|
(check (∘ not bound-identifier=?) #'zz #'d1)
|
|
(check (∘ not bound-identifier=?) #'zz #'d2)
|
|
(check (∘ not bound-identifier=?) #'zz #'z)
|
|
(check (∘ not bound-identifier=?) #'zz #'zzz)
|
|
|
|
(check (∘ not bound-identifier=?) #'zzz #'y)
|
|
(check (∘ not bound-identifier=?) #'zzz #'yy)
|
|
(check (∘ not bound-identifier=?) #'zzz #'yyy)
|
|
(check (∘ not bound-identifier=?) #'zzz #'d1)
|
|
(check (∘ not bound-identifier=?) #'zzz #'d2)
|
|
(check (∘ not bound-identifier=?) #'zzz #'z)
|
|
(check (∘ not bound-identifier=?) #'zzz #'zz)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c d)
|
|
[(_ xⱼ zᵢ …)
|
|
(list (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))
|
|
(subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …)))])
|
|
[(([x1 w1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'b)
|
|
(check bound-identifier=? #'foo1 #'foo)
|
|
(check bound-identifier=? #'z1 #'c)
|
|
(check bound-identifier=? #'zz1 #'d)
|
|
|
|
(check bound-identifier=? #'x2 #'b)
|
|
(check bound-identifier=? #'foo2 #'foo)
|
|
(check bound-identifier=? #'z2 #'c)
|
|
(check bound-identifier=? #'zz2 #'d)
|
|
|
|
(check bound-identifier=? #'x1 #'x2)
|
|
(check bound-identifier=? #'w1 #'w2)
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'pp1)])
|
|
|
|
(syntax-parse (syntax-parse #'()
|
|
[()
|
|
(syntax-parse #'(a b)
|
|
[(zᵢ …)
|
|
(list (syntax-parse #'(e)
|
|
[(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
|
|
(syntax-parse #'(e) ;; TODO: same test with f
|
|
[(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])
|
|
[(([x1 w1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'e)
|
|
(check bound-identifier=? #'foo1 #'foo)
|
|
(check bound-identifier=? #'z1 #'a)
|
|
(check bound-identifier=? #'zz1 #'b)
|
|
|
|
(check bound-identifier=? #'x2 #'e)
|
|
(check bound-identifier=? #'foo2 #'foo)
|
|
(check bound-identifier=? #'z2 #'a)
|
|
(check bound-identifier=? #'zz2 #'b)
|
|
|
|
(check bound-identifier=? #'x1 #'x2)
|
|
(check (∘ not bound-identifier=?) #'w1 #'w2) ;; yes above, no here.
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'pp1)])
|
|
|
|
(syntax-parse (syntax-parse #'()
|
|
[()
|
|
(syntax-parse #'(a b)
|
|
[(zᵢ …)
|
|
(list (syntax-parse #'(e)
|
|
[(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))])
|
|
(syntax-parse #'(f) ;; above: was e, not f
|
|
[(xⱼ) (subtemplate ([xⱼ wⱼ] foo [zᵢ pᵢ] …))]))])])
|
|
[(([x1 w1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'e)
|
|
(check bound-identifier=? #'foo1 #'foo)
|
|
(check bound-identifier=? #'z1 #'a)
|
|
(check bound-identifier=? #'zz1 #'b)
|
|
|
|
(check bound-identifier=? #'x2 #'f) ;; above: was e, not f
|
|
(check bound-identifier=? #'foo2 #'foo)
|
|
(check bound-identifier=? #'z2 #'a)
|
|
(check bound-identifier=? #'zz2 #'b)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'x2) ;; yes above, no here.
|
|
(check (∘ not bound-identifier=?) #'w1 #'w2) ;; yes above above, no here.
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'pp1)])
|
|
|
|
(syntax-parse (syntax-parse #'()
|
|
[()
|
|
(syntax-parse #'(a b)
|
|
[(zᵢ …)
|
|
(list (syntax-parse #'(c d)
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
|
|
(syntax-parse #'(cc dd)
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])
|
|
[(([x1 w1] [xx1 ww1] foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] [xx2 ww2] foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'c)
|
|
(check bound-identifier=? #'xx1 #'d)
|
|
(check bound-identifier=? #'foo1 #'foo)
|
|
(check bound-identifier=? #'z1 #'a)
|
|
(check bound-identifier=? #'zz1 #'b)
|
|
|
|
(check bound-identifier=? #'x2 #'cc)
|
|
(check bound-identifier=? #'xx2 #'dd)
|
|
(check bound-identifier=? #'foo2 #'foo)
|
|
(check bound-identifier=? #'z2 #'a)
|
|
(check bound-identifier=? #'zz2 #'b)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'x2)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'xx2)
|
|
(check bound-identifier=? #'w1 #'w2)
|
|
(check bound-identifier=? #'ww1 #'ww2)
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'xx1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'x1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'xx1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'p1)
|
|
(check (∘ not bound-identifier=?) #'w1 #'pp1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'xx1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'x1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'w1)
|
|
(check (∘ not bound-identifier=?) #'p1 #'pp1)])
|
|
|
|
(check-exn #px"incompatible ellipsis match counts for subscripted variables"
|
|
(λ ()
|
|
(syntax-parse #'()
|
|
[()
|
|
(syntax-parse #'(a b)
|
|
[(zᵢ …)
|
|
(list (syntax-parse #'(c) ;; one here, two above and below
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))])
|
|
(syntax-parse #'(cc dd)
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … foo [zᵢ pᵢ] …))]))])])))
|
|
|
|
;; Test for arrows, with two maximal candidates tᵢ and zᵢ :
|
|
;; the arrow should be drawn to the ᵢ in wᵢ and pᵢ from the ᵢ in the bindings
|
|
;; for both tᵢ and zᵢ. For the uses of xᵢ, tᵢ and zᵢ, there should be only one
|
|
;; arrow, drawn from the correponding binding.
|
|
(syntax-parse (syntax-parse #'()
|
|
[()
|
|
(syntax-parse #'([a b] [aa bb])
|
|
[([tᵢ …] [zᵢ …])
|
|
(list (syntax-parse #'(c d)
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))])
|
|
(syntax-parse #'(cc dd)
|
|
[(xᵢ …)
|
|
(subtemplate ([xᵢ wᵢ] … tᵢ … foo [zᵢ pᵢ] …))]))])])
|
|
[(([x1 w1] [xx1 ww1] t1 tt1 foo1 [z1 p1] [zz1 pp1])
|
|
([x2 w2] [xx2 ww2] t2 tt2 foo2 [z2 p2] [zz2 pp2]))
|
|
(check bound-identifier=? #'x1 #'c)
|
|
(check bound-identifier=? #'xx1 #'d)
|
|
(check bound-identifier=? #'x2 #'cc)
|
|
(check bound-identifier=? #'xx2 #'dd)
|
|
|
|
(check bound-identifier=? #'t1 #'a)
|
|
(check bound-identifier=? #'tt1 #'b)
|
|
(check bound-identifier=? #'t2 #'a)
|
|
(check bound-identifier=? #'tt2 #'b)
|
|
|
|
(check (∘ not bound-identifier=?) #'x1 #'x2)
|
|
(check bound-identifier=? #'w1 #'w2)
|
|
(check (∘ not bound-identifier=?) #'xx1 #'xx2)
|
|
(check bound-identifier=? #'ww1 #'ww2)
|
|
(check bound-identifier=? #'t1 #'t2)
|
|
(check bound-identifier=? #'tt1 #'tt2)
|
|
(check bound-identifier=? #'foo1 #'foo2)
|
|
(check bound-identifier=? #'z1 #'z2)
|
|
(check bound-identifier=? #'p1 #'p2)
|
|
(check bound-identifier=? #'zz1 #'zz2)
|
|
(check bound-identifier=? #'pp1 #'pp2)])
|
|
|
|
;; Check that the derived values are NOT cached across runs of the same
|
|
;; pattern+template (GH bug #1).
|
|
(check-equal? (map (λ (v)
|
|
(syntax->datum
|
|
(syntax-parse v
|
|
[(xᵢ …) (subtemplate (yᵢ …))])))
|
|
(list #'[] #'[a] #'[a b] #'[c d e f]))
|
|
'([] [a/y] [a/y b/y] [c/y d/y e/y f/y]))
|
|
|
|
(check-equal? (map (λ (v)
|
|
(syntax->datum
|
|
(syntax-parse v
|
|
[(xᵢ …) (subtemplate (xᵢ … yᵢ …))])))
|
|
(list #'[] #'[a] #'[a b] #'[c d e f]))
|
|
'([] [a a/y] [a b a/y b/y] [c d e f c/y d/y e/y f/y]))
|
|
|
|
(check-equal? (map (λ (v)
|
|
(syntax->datum
|
|
(syntax-parse v
|
|
[(xᵢ …) (subtemplate ([xᵢ yᵢ] …))])))
|
|
(list #'[] #'[a] #'[a b] #'[c d e f]))
|
|
'(()
|
|
([a a/y])
|
|
([a a/y] [b b/y])
|
|
([c c/y] [d d/y] [e e/y] [f f/y])))
|
|
|
|
;; ~optional
|
|
(begin
|
|
;; whole opt present, yᵢ ... ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(1 2 3) (a b)])
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? (yᵢ ... ...) empty})]))
|
|
'(1/y 2/y 3/y a/y b/y))
|
|
|
|
;; whole opt empty, yᵢ ... ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'()
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? (yᵢ ... ...) empty})]))
|
|
'empty)
|
|
|
|
;; whole opt present, ([xᵢ yᵢ] ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(1 2 3) (a b)])
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? (([xᵢ yᵢ] ...) ...) empty})]))
|
|
'(([1 1/y] [2 2/y] [3 3/y]) ([a a/y] [b b/y])))
|
|
|
|
;; whole opt empty, ([xᵢ yᵢ] ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'()
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? (([xᵢ yᵢ] ...) ...) empty})]))
|
|
'empty)
|
|
|
|
;; whole opt present, (yᵢ ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(1 2 3) (a b)])
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? ((yᵢ ...) ...) empty})]))
|
|
'((1/y 2/y 3/y) (a/y b/y)))
|
|
|
|
;; whole opt empty, (yᵢ ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'()
|
|
[({~optional ((xᵢ ...) ...)})
|
|
(subtemplate {?? (yᵢ ... ...) empty})]))
|
|
'empty)
|
|
|
|
;; level-1 opt, (?@ [xᵢ yᵢ] ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'((1 2 3) #:kw (a b) #:kw)
|
|
[({~and {~or (xᵢ ...) #:kw}} ...)
|
|
(subtemplate ({?? (?@ [xᵢ yᵢ] ...) empty} ...))]))
|
|
'([1 1/y] [2 2/y] [3 3/y] empty [a a/y] [b b/y] empty))
|
|
|
|
;; level-1 opt, (?@ yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'((1 2 3) #:kw (a b) #:kw)
|
|
[({~and {~or (xᵢ ...) #:kw}} ...)
|
|
(subtemplate ({?? (?@ yᵢ ...) empty} ...))]))
|
|
'(1/y 2/y 3/y empty a/y b/y empty))
|
|
|
|
;; level-1 opt, ([xᵢ yᵢ] ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'((1 2 3) #:kw (a b) #:kw)
|
|
[({~and {~or (xᵢ ...) #:kw}} ...)
|
|
(subtemplate ({?? ([xᵢ yᵢ] ...) empty} ...))]))
|
|
'(([1 1/y] [2 2/y] [3 3/y]) empty ([a a/y] [b b/y]) empty))
|
|
|
|
;; level-1 opt, (xᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'((1 2 3) #:kw (a b) #:kw)
|
|
[({~and {~or (xᵢ ...) #:kw}} ...)
|
|
(quasisubtemplate
|
|
({?? (xᵢ ...) empty} ...))]))
|
|
'((1 2 3) empty (a b) empty))
|
|
|
|
;; level-1 opt, (yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'((1 2 3) #:kw (a b) #:kw)
|
|
[({~and {~or (xᵢ ...) #:kw}} ...)
|
|
(subtemplate ({?? (yᵢ ...) empty} ...))]))
|
|
'((1/y 2/y 3/y) empty (a/y b/y) empty))
|
|
|
|
;; level-1 opt + same but with all #f filled in.
|
|
(begin
|
|
;; level-1 opt + same but with all #f filled in. (wᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (wᵢ ...) empty} ...))]))
|
|
'((e f g)
|
|
(h i)
|
|
(j k)
|
|
(l m n o)))
|
|
|
|
;; level-1 opt + same but with some filled/missing. (wᵢ/empty ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (({?? wᵢ empty} ...) ...))]))
|
|
'((e f g)
|
|
(h i)
|
|
(j k)
|
|
(l m n o)))
|
|
|
|
;; level-1 opt + same but with all #f filled in. ([wᵢ yᵢ] ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? ([wᵢ yᵢ] ...) empty} ...))]))
|
|
'(([e 1/y] [f 2/y] [g 3/y])
|
|
([h h/y] [i i/y])
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y])))
|
|
|
|
;; level-1 opt + same but with all #f filled in. (yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (yᵢ ...) empty} ...))]))
|
|
'((1/y 2/y 3/y)
|
|
(h/y i/y)
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y)))
|
|
|
|
;; level-1 opt + same but with all #f filled in. (yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (?@ yᵢ ...) empty} ...))]))
|
|
'(1/y 2/y 3/y h/y i/y a/y b/y l/y m/y n/y o/y))
|
|
|
|
;; level-1 opt + same but with all #f filled in. ([wᵢ yᵢ/empty] ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (([wᵢ (?? yᵢ empty)] ...) ...))]))
|
|
'(([e 1/y] [f 2/y] [g 3/y])
|
|
([h h/y] [i i/y])
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y])))
|
|
|
|
;; level-1 opt + same but with all #f filled in. (yᵢ/empty ...) ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (((?? yᵢ empty) ...) ...))]))
|
|
'((1/y 2/y 3/y)
|
|
(h/y i/y)
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y)))
|
|
|
|
;; level-1 opt + same but with all #f filled in. yᵢ/empty ... ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) (h i) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ((?? yᵢ empty) ... ...))]))
|
|
'(1/y 2/y 3/y
|
|
h/y i/y
|
|
a/y b/y
|
|
l/y m/y n/y o/y)))
|
|
|
|
|
|
;; level-1 opt + same but with some level-1 #f filled in and some missing
|
|
(begin
|
|
;; level-1 opt + same with some lvl1 filled/missing. (wᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (wᵢ ...) empty} ...))]))
|
|
'((e f g)
|
|
empty
|
|
(j k)
|
|
(l m n o)))
|
|
|
|
;; level-1 opt + same with some lvl1 filled/missing. (wᵢ/empty ...) ...
|
|
;; Invalid because {?? wᵢ empty} ... means to iterate over the known
|
|
;; elements of wᵢ, and put "empty" if one is absent. However, the whole
|
|
;; sublist of wᵢ element is missing, so it does not really have a meaningful
|
|
;; length for the ...
|
|
(check-exn
|
|
#rx"attribute contains non-(syntax|list) value.*#f"
|
|
(λ ()
|
|
(convert-compile-time-error
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (({?? wᵢ empty} ...) ...))]))
|
|
'((e f g)
|
|
empty
|
|
(j k)
|
|
(l m n o))))))
|
|
|
|
;; level-1 opt + same with some lvl1 filled/missing. ([wᵢ yᵢ] ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? ([wᵢ yᵢ] ...) empty} ...))]))
|
|
'(([e 1/y] [f 2/y] [g 3/y])
|
|
empty
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y])))
|
|
|
|
;; level-1 opt + same with some lvl1 #f filled in. (yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (yᵢ ...) empty} ...))]))
|
|
'((1/y 2/y 3/y)
|
|
empty
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y)))
|
|
|
|
;; level-1 opt + same with some lvl1 #f filled in. (yᵢ ...)/empty ...
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (?@ yᵢ ...) empty} ...))]))
|
|
'(1/y 2/y 3/y
|
|
empty
|
|
a/y b/y
|
|
l/y m/y n/y o/y))
|
|
|
|
;; level-1 opt + same with some lvl1 #f filled in. ([wᵢ yᵢ/empty] ...) ...
|
|
;; Invalid because {?? wᵢ emptywi} ... means to iterate over the known
|
|
;; elements of wᵢ, and put "empty" if one is absent. However, the whole
|
|
;; sublist of wᵢ element is missing, so it does not really have a meaningful
|
|
;; length for the ...
|
|
(check-exn
|
|
#rx"attribute contains non-(syntax|list) value.*#f"
|
|
(λ ()
|
|
(convert-compile-time-error
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate
|
|
(([(?? wᵢ emptywi) (?? yᵢ empty)] ...) ...))]))
|
|
'(([e 1/y] [f 2/y] [g 3/y])
|
|
([emptywi empty] [emptywi empty])
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y]))))))
|
|
|
|
;; level-1 opt + same with some lvl1 #f filled in. (yᵢ/empty ...) ...
|
|
;; Invalid because {?? wᵢ empty} ... means to iterate over the known
|
|
;; elements of wᵢ, and put "empty" if one is absent. However, the whole
|
|
;; sublist of wᵢ element is missing, so it does not really have a meaningful
|
|
;; length for the ...
|
|
(check-exn
|
|
#rx"attribute contains non-(syntax|list) value.*#f"
|
|
(λ ()
|
|
(convert-compile-time-error
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (((?? yᵢ empty) ...) ...))]))
|
|
'((1/y 2/y 3/y)
|
|
empty
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y))))))
|
|
|
|
;; level-1 opt + same with some lvl1 #f filled in. yᵢ/empty ... ...
|
|
;; Invalid because {?? yᵢ empty} ... means to iterate over the known
|
|
;; elements of wᵢ, and put "empty" if one is absent. However, the whole
|
|
;; sublist of wᵢ element is missing, so it does not really have a meaningful
|
|
;; length for the ...
|
|
(check-exn
|
|
#rx"attribute contains non-(syntax|list) value.*#f"
|
|
(λ ()
|
|
(convert-compile-time-error
|
|
(check-equal? (syntax->datum
|
|
(syntax-parse #'([(e f g) #:k (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[(({~and {~or (wᵢ ...) #:k}} ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ((?? yᵢ empty) ... ...))]))
|
|
'(1/y 2/y 3/y
|
|
empty
|
|
a/y b/y
|
|
l/y m/y n/y o/y))))))
|
|
|
|
|
|
;; level-1 opt + same with some level-2 #f filled in and some missing
|
|
(begin
|
|
;; level-1 opt + same with some lvl2 filled/missing. (wᵢ ...)/empty ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (wᵢ ...) empty} ...))]))
|
|
'((e f g)
|
|
empty
|
|
(j k)
|
|
(l m n o)))
|
|
|
|
;; level-1 opt + same with some lvl2 filled/missing. (wᵢ/empty ...) ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (({?? wᵢ empty} ...) ...))]))
|
|
'((e f g)
|
|
(h empty)
|
|
(j k)
|
|
(l m n o)))
|
|
|
|
;; level-1 opt + same with some lvl2 filled/missing. ([wᵢ yᵢ] ...)/empty ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? ([wᵢ yᵢ] ...) empty} ...))]))
|
|
'(([e 1/y] [f 2/y] [g 3/y])
|
|
empty
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y])))
|
|
|
|
;; level-1 opt + same but with some #f filled in. (yᵢ ...)/empty ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (yᵢ ...) empty} ...))]))
|
|
`((1/y 2/y 3/y)
|
|
(h/y ,(? symbol?
|
|
(app symbol->string (regexp #rx"xᵢ[0-9]+/y"))))
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y)))
|
|
|
|
;; level-1 opt + same but with some #f filled in. (yᵢ ...)/empty ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ({?? (?@ yᵢ ...) empty} ...))]))
|
|
`(1/y 2/y 3/y
|
|
h/y ,(? symbol?
|
|
(app symbol->string (regexp #rx"xᵢ[0-9]+/y")))
|
|
a/y b/y
|
|
l/y m/y n/y o/y))
|
|
|
|
;; level-1 opt + same but with some #f filled in. ([wᵢ yᵢ/empty] ...) ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate
|
|
(([(?? wᵢ emptywi) (?? yᵢ empty)] ...) ...))]))
|
|
`(([e 1/y] [f 2/y] [g 3/y])
|
|
([h h/y]
|
|
[emptywi
|
|
,(? symbol?
|
|
(app symbol->string (regexp #rx"xᵢ[0-9]+/y")))])
|
|
([j a/y] [k b/y])
|
|
([l l/y] [m m/y] [n n/y] [o o/y])))
|
|
|
|
;; level-1 opt + same but with some #f filled in. (yᵢ/empty ...) ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate (((?? yᵢ empty) ...) ...))]))
|
|
`((1/y 2/y 3/y)
|
|
(h/y ,(? symbol?
|
|
(app symbol->string (regexp #rx"xᵢ[0-9]+/y"))))
|
|
(a/y b/y)
|
|
(l/y m/y n/y o/y)))
|
|
|
|
;; level-1 opt + same but with some #f filled in. yᵢ/empty ... ...
|
|
(check-match (syntax->datum
|
|
(syntax-parse #'([(e f g) (h #:k) (j k) (l m n o)]
|
|
[(1 2 3) #:kw (a b) #:kw])
|
|
[((({~and {~or wᵢ:id #:k}} ...) ...)
|
|
({~and {~or (xᵢ ...) #:kw}} ...))
|
|
(subtemplate ((?? yᵢ empty) ... ...))]))
|
|
`(1/y 2/y 3/y
|
|
h/y ,(? symbol?
|
|
(app symbol->string (regexp #rx"xᵢ[0-9]+/y")))
|
|
a/y b/y
|
|
l/y m/y n/y o/y))))
|
|
|
|
;; Incompatible shapes of different derived attributes:
|
|
(check-exn
|
|
#rx"some derived variables do not have the same ellipsis shape"
|
|
(λ ()
|
|
(convert-compile-time-error
|
|
(syntax-parse #'([1 2 3] #f)
|
|
[({~and {~or (xᵢ ...) #f}} ...)
|
|
(subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
|
|
(syntax-case #'([a b c] [d e]) ()
|
|
;; introduces elements [d e] which were unknown when yᵢ was
|
|
;; generated:
|
|
[((wᵢ ...) ...)
|
|
;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
|
|
;; inconsistent with the shape of yᵢ.
|
|
(subtemplate ({?? (zᵢ ...) _} ...))])]))))
|
|
|
|
;; Incompatible shapes of the same attribute if it were generated at two
|
|
;; different points.
|
|
(check-exn
|
|
#rx"some derived variables do not have the same ellipsis shape"
|
|
(λ ()
|
|
(syntax-parse #'([1 2 3] #f)
|
|
[({~and {~or (xᵢ ...) #f}} ...)
|
|
(subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _)
|
|
(syntax-case #'([a b c] [d e]) ()
|
|
;; introduces elements [d e] which were unknown when yᵢ was
|
|
;; generated:
|
|
[((wᵢ ...) ...)
|
|
;; Would give ((a/z b/z c/z) (d/z e/z)), but this is
|
|
;; inconsistent with the shape of yᵢ.
|
|
(subtemplate ({?? (yᵢ ...) _} ...))])]))) |