209 lines
7.9 KiB
Racket
209 lines
7.9 KiB
Racket
#lang racket
|
|
(require "../subtemplate.rkt"
|
|
phc-toolkit/untyped
|
|
rackunit)
|
|
|
|
(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)
|
|
|
|
(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 free-identifier=? #'x1 #'x2)
|
|
(check free-identifier=? #'w1 #'w2)
|
|
(check free-identifier=? #'foo1 #'foo2)
|
|
(check free-identifier=? #'z1 #'z2)
|
|
(check free-identifier=? #'p1 #'p2)
|
|
(check free-identifier=? #'zz1 #'zz2)
|
|
(check free-identifier=? #'pp1 #'pp2)
|
|
|
|
(check free-identifier=? #'x1 #'b)
|
|
(check free-identifier=? #'z1 #'c)
|
|
(check free-identifier=? #'zz1 #'d)
|
|
|
|
(check free-identifier=? #'x2 #'b)
|
|
(check free-identifier=? #'z2 #'c)
|
|
(check free-identifier=? #'zz2 #'d)
|
|
|
|
;; The *1 are all different:
|
|
(check free-identifier=? #'x1 #'x1)
|
|
(check (∘ not free-identifier=?) #'x1 #'w1)
|
|
(check (∘ not free-identifier=?) #'x1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'x1 #'z1)
|
|
(check (∘ not free-identifier=?) #'x1 #'p1)
|
|
(check (∘ not free-identifier=?) #'x1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'x1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'w1 #'x1)
|
|
(check free-identifier=? #'w1 #'w1)
|
|
(check (∘ not free-identifier=?) #'w1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'w1 #'z1)
|
|
(check (∘ not free-identifier=?) #'w1 #'p1)
|
|
(check (∘ not free-identifier=?) #'w1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'w1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'foo1 #'x1)
|
|
(check (∘ not free-identifier=?) #'foo1 #'w1)
|
|
(check free-identifier=? #'foo1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'foo1 #'z1)
|
|
(check (∘ not free-identifier=?) #'foo1 #'p1)
|
|
(check (∘ not free-identifier=?) #'foo1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'foo1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'z1 #'x1)
|
|
(check (∘ not free-identifier=?) #'z1 #'w1)
|
|
(check (∘ not free-identifier=?) #'z1 #'foo1)
|
|
(check free-identifier=? #'z1 #'z1)
|
|
(check (∘ not free-identifier=?) #'z1 #'p1)
|
|
(check (∘ not free-identifier=?) #'z1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'z1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'p1 #'x1)
|
|
(check (∘ not free-identifier=?) #'p1 #'w1)
|
|
(check (∘ not free-identifier=?) #'p1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'p1 #'z1)
|
|
(check free-identifier=? #'p1 #'p1)
|
|
(check (∘ not free-identifier=?) #'p1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'p1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'zz1 #'x1)
|
|
(check (∘ not free-identifier=?) #'zz1 #'w1)
|
|
(check (∘ not free-identifier=?) #'zz1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'zz1 #'z1)
|
|
(check (∘ not free-identifier=?) #'zz1 #'p1)
|
|
(check free-identifier=? #'zz1 #'zz1)
|
|
(check (∘ not free-identifier=?) #'zz1 #'pp1)
|
|
|
|
(check (∘ not free-identifier=?) #'pp1 #'x1)
|
|
(check (∘ not free-identifier=?) #'pp1 #'w1)
|
|
(check (∘ not free-identifier=?) #'pp1 #'foo1)
|
|
(check (∘ not free-identifier=?) #'pp1 #'z1)
|
|
(check (∘ not free-identifier=?) #'pp1 #'p1)
|
|
(check (∘ not free-identifier=?) #'pp1 #'zz1)
|
|
(check free-identifier=? #'pp1 #'pp1)
|
|
|
|
;; The *2 are all different:
|
|
(check free-identifier=? #'x2 #'x2)
|
|
(check (∘ not free-identifier=?) #'x2 #'w2)
|
|
(check (∘ not free-identifier=?) #'x2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'x2 #'z2)
|
|
(check (∘ not free-identifier=?) #'x2 #'p2)
|
|
(check (∘ not free-identifier=?) #'x2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'x2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'w2 #'x2)
|
|
(check free-identifier=? #'w2 #'w2)
|
|
(check (∘ not free-identifier=?) #'w2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'w2 #'z2)
|
|
(check (∘ not free-identifier=?) #'w2 #'p2)
|
|
(check (∘ not free-identifier=?) #'w2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'w2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'foo2 #'x2)
|
|
(check (∘ not free-identifier=?) #'foo2 #'w2)
|
|
(check free-identifier=? #'foo2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'foo2 #'z2)
|
|
(check (∘ not free-identifier=?) #'foo2 #'p2)
|
|
(check (∘ not free-identifier=?) #'foo2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'foo2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'z2 #'x2)
|
|
(check (∘ not free-identifier=?) #'z2 #'w2)
|
|
(check (∘ not free-identifier=?) #'z2 #'foo2)
|
|
(check free-identifier=? #'z2 #'z2)
|
|
(check (∘ not free-identifier=?) #'z2 #'p2)
|
|
(check (∘ not free-identifier=?) #'z2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'z2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'p2 #'x2)
|
|
(check (∘ not free-identifier=?) #'p2 #'w2)
|
|
(check (∘ not free-identifier=?) #'p2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'p2 #'z2)
|
|
(check free-identifier=? #'p2 #'p2)
|
|
(check (∘ not free-identifier=?) #'p2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'p2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'zz2 #'x2)
|
|
(check (∘ not free-identifier=?) #'zz2 #'w2)
|
|
(check (∘ not free-identifier=?) #'zz2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'zz2 #'z2)
|
|
(check (∘ not free-identifier=?) #'zz2 #'p2)
|
|
(check free-identifier=? #'zz2 #'zz2)
|
|
(check (∘ not free-identifier=?) #'zz2 #'pp2)
|
|
|
|
(check (∘ not free-identifier=?) #'pp2 #'x2)
|
|
(check (∘ not free-identifier=?) #'pp2 #'w2)
|
|
(check (∘ not free-identifier=?) #'pp2 #'foo2)
|
|
(check (∘ not free-identifier=?) #'pp2 #'z2)
|
|
(check (∘ not free-identifier=?) #'pp2 #'p2)
|
|
(check (∘ not free-identifier=?) #'pp2 #'zz2)
|
|
(check free-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 free-identifier=? #'a2 #'a3)
|
|
(check free-identifier=? #'b2 #'b3)
|
|
(check free-identifier=? #'c2 #'c3)
|
|
(check (∘ not free-identifier=?) #'a1 #'a2)
|
|
(check (∘ not free-identifier=?) #'b1 #'b2)
|
|
(check (∘ not free-identifier=?) #'c1 #'c2)])
|
|
|
|
(syntax-parse (syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
;; must be from xᵢ, not yᵢ
|
|
#,(quasisubtemplate (zᵢ …))
|
|
zᵢ …))])
|
|
[(a1 b1 c1 (a2 b2 c2) a3 b3 c3)
|
|
(check free-identifier=? #'a2 #'a3)
|
|
(check free-identifier=? #'b2 #'b3)
|
|
(check free-identifier=? #'c2 #'c3)
|
|
(check (∘ not free-identifier=?) #'a1 #'a2)
|
|
(check (∘ not free-identifier=?) #'b1 #'b2)
|
|
(check (∘ not free-identifier=?) #'c1 #'c2)])
|
|
;; the test above is not exactly right (zᵢ will still have the correct
|
|
;; binding), but it gives the general idea.
|
|
|
|
(syntax->datum
|
|
(syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(define flob (syntax-parse #'d [d (quasisubtemplate (zᵢ …))]))
|
|
(quasisubtemplate (yᵢ …
|
|
;; must be from xᵢ, not yᵢ
|
|
#,flob
|
|
zᵢ …))]))
|
|
|
|
(syntax->datum
|
|
(syntax-parse #'(a b c)
|
|
[(xᵢ …)
|
|
(quasisubtemplate (yᵢ …
|
|
;; must be from xᵢ, not yᵢ
|
|
#,(syntax-parse #'d [d (quasisubtemplate (zᵢ …))])
|
|
zᵢ …))]))
|