highlight!
(library (tests r6rs syntax-case)
(export run-syntax-case-tests)
(import (for (rnrs) run expand)
(rename (only (rnrs base) cons) (cons kons))
(tests r6rs test))
(define (unwrap s)
(cond
[(pair? s) (cons (unwrap (car s)) (unwrap (cdr s)))]
[(vector? s) (list->vector (map unwrap (vector->list s)))]
[(null? s) s]
[(number? s) s]
[(string? s) s]
[(boolean? s) s]
[else (syntax->datum s)]))
(define p (cons 4 5))
(define-syntax p.car
(lambda (x)
(syntax-case x ()
[(_ . rest) #'((car p) . rest)]
[_ #'(car p)])))
(define p2 (cons 4 5))
(define-syntax p2.car
(make-variable-transformer
(lambda (x)
(syntax-case x (set!)
[(set! _ e) #'(set! p2 (cons e (cdr p2)))]
[(_ . rest) #'((car p2) . rest)]
[_ #'(car p2)]))))
(define-syntax rec
(lambda (x)
(syntax-case x ()
[(_ x e)
(identifier? #'x)
#'(letrec ([x e]) x)])))
(define-syntax loop
(lambda (x)
(syntax-case x ()
[(k e ...)
(with-syntax
([break (datum->syntax #'k 'break)])
#'(call-with-current-continuation
(lambda (break)
(let f () e ... (f)))))])))
(define (run-syntax-case-tests)
(test p.car 4)
(set! p2.car 15)
(test p2.car 15)
(test p2 '(15 . 5))
(test (map (rec fact
(lambda (n)
(if (= n 0)
1
(* n (fact (- n 1))))))
'(1 2 3 4 5))
'(1 2 6 24 120))
(test
(let ([fred 17])
(define-syntax a
(lambda (x)
(syntax-case x ()
[(_ id) #'(b id fred)])))
(define-syntax b
(lambda (x)
(syntax-case x ()
[(_ id1 id2)
#`(list
#,(free-identifier=? #'id1 #'id2)
#,(bound-identifier=? #'id1 #'id2))])))
(a fred))
'(#t #f))
(test (let-syntax
([dolet (lambda (x)
(syntax-case x ()
[(_ b)
#'(let ([a 3] [b 4]) (+ a b))]))])
(dolet a))
7)
(test 6
(let-syntax ([foo
(syntax-rules ()
[(_)
(let-syntax ([bar
(syntax-rules ()
[(_) 5])])
(bar))])])
(+ 1 (foo))))
(test (let ((n 3) (ls '()))
(loop
(if (= n 0) (break ls))
(set! ls (cons 'a ls))
(set! n (- n 1))))
'(a a a))
(test (syntax-case #'1 () [1 'one]) 'one)
(test (syntax-case #'(1) () [(1) 'one]) 'one)
(test (syntax-case '(1) () [(x) #'x]) 1)
(test (syntax-case #'(1) () [(x) (syntax->datum #'x)]) 1)
(test (syntax-case '("a") () [(x) #'x]) "a")
(test (syntax-case #'("a") () [(x) (syntax->datum #'x)]) "a")
(test (syntax-case '(1 #f "s" #vu8(9) #(5 7)) ()
[(x ...) #'(x ...)])
'(1 #f "s" #vu8(9) #(5 7)))
(test (syntax-case #'(1 #f "s" #vu8(9) #(5 7)) ()
[(x ...) (map syntax->datum #'(x ...))])
'(1 #f "s" #vu8(9) #(5 7)))
(test (syntax-case '(1 2 3 4) () [(x y . z) #'z]) '(3 4))
(test (syntax-case #'(a b c d) () [(x y . z) (syntax->datum #'z)])
'(c d))
(test (syntax-case #'(nonesuch 12) (nonesuch)
[(nonesuch x) (syntax->datum #'x)])
12)
(test (syntax-case #'(different 12) (nonesuch)
[(nonesuch x) #'x]
[_ 'other])
'other)
(test (syntax-case '(1 2 3 4) ()
[(1 x ...) #'(x ...)])
'(2 3 4))
(test (syntax-case '(1 2 3 4) ()
[(1 x ... 3 4) #'(x ...)])
'(2))
(test (syntax-case '(1 2 3 4) ()
[(1 x ... 2 3 4) #'(x ...)])
'())
(test (syntax-case '(1 2 3 4) ()
[(1 x ... . y) #'y])
'())
(test (syntax-case '(1 2 3 4 . 5) ()
[(1 x ... . y) #'y])
'5)
(test (syntax-case '(1 2 3 4 . 5) ()
[(1 x ... 4 . y) #'y])
'5)
(test (syntax-case '(1 2 3 4 . 5) ()
[(1 x ... 5 . y) #'y]
[_ 'no])
'no)
(test (syntax-case '#(1 2 3 4) ()
[#(1 x y 4) (car #'(x y))])
'2)
(test (syntax-case '#(1 2 3 4) ()
[#(1 x y 4) (cadr #'(x y))])
'3)
(test (syntax-case '#(1 2 3 4) ()
[#(1 x y 4) (syntax->datum (cddr #'(x y)))])
'())
(test (syntax-case '#(1 2 3 4) ()
[#(1 2 3 4) 'match])
'match)
(test (syntax-case '#(1 2 3 4) ()
[#(1 x y 4) #'y])
'3)
(test (syntax-case '#(1 2 3 4) ()
[#(1 x ...) #'(x ...)])
'(2 3 4))
(test (syntax-case '#(1 2 3 4) ()
[#(1 x ... 4) #'(x ...)])
'(2 3))
(test (syntax-case '#(1 2 3 4) ()
[#(1 x ... 2 3 4) #'(x ...)])
'())
(test (syntax-case #'() ()
[(x ...)
(let ([v #'#(x ...)])
(list (syntax->datum v) (vector? v)))])
'(#() #t))
(test (syntax-case #'(1) ()
[(_) (syntax->datum #'_)])
'_)
(test (syntax-case '((a) (b c)) ()
[((x ...) ...)
#'(x ... ...)])
'(a b c))
(test (syntax-case #'((a) (b c)) ()
[((x ...) ...)
(map syntax->datum #'(x ... ...))])
'(a b c))
(test (identifier? 'x) #f)
(test (identifier? #'x) #t)
(test (bound-identifier=? #'x #'x) #t)
(test (bound-identifier=? #'x #'y) #f)
(test (bound-identifier=? #'cons #'kons) #f)
(test (free-identifier=? #'x #'x) #t)
(test (free-identifier=? #'x #'y) #f)
(test (free-identifier=? #'cons #'kons) #t)
(test (syntax->datum #'1) 1)
(test (syntax->datum #'a) 'a)
(test (syntax->datum #'(a b)) '(a b))
(test (syntax->datum #'(a . b)) '(a . b))
(test (syntax->datum '1) 1)
(test (syntax->datum '(1 . 2)) '(1 . 2))
(test (syntax->datum '(1 2)) '(1 2))
(test (syntax->datum (cons #'a #'b)) '(a . b))
(test (syntax->datum (vector #'a #'b)) '#(a b))
(test (syntax->datum '#(1 2)) '#(1 2))
(test (syntax->datum (datum->syntax #'x 1)) 1)
(test (syntax->datum (datum->syntax #'x 'a)) 'a)
(test (syntax->datum (datum->syntax #'x '(a b))) '(a b))
(test (syntax->datum (datum->syntax #'x '(a . b))) '(a . b))
(test (number? (car (syntax->datum (datum->syntax #'x (list 1))))) #t)
(test (map identifier? (generate-temporaries '(1 2 3))) '(#t #t #t))
(test (map identifier? (generate-temporaries #'(1 2 3))) '(#t #t #t))
(test (map identifier? (generate-temporaries (cons 1 #'(2 3)))) '(#t #t #t))
(test (cadr (with-syntax ([x 1]
[y 2])
#'(x y)))
2)
(test (syntax->datum #`(1 2 3)) '(1 2 3))
(test (syntax->datum #`1) 1)
(test (let ([v #`(1 #,(+ 1 1) 3)])
(list (pair? v)
(syntax->datum (car v))
(cadr v)
(syntax->datum (cddr v))))
'(#t 1 2 (3)))
(test (let ([v #`(1 #,@(list (+ 1 1)) 3)])
(list (pair? v)
(syntax->datum (car v))
(cadr v)
(syntax->datum (cddr v))))
'(#t 1 2 (3)))
(test (let ([v #`(1 #,@(list (+ 1 1) (- 8 1)) 3)])
(list (pair? v)
(syntax->datum (car v))
(cadr v)
(caddr v)
(syntax->datum (cdddr v))))
'(#t 1 2 7 (3)))
(test (syntax-case '(1 2 3) ()
[(x ...) #`(x ...)])
'(1 2 3))
(test (unwrap
#`(1 2 (unsyntax 3 4 5) 6))
'(1 2 3 4 5 6))
(test (unwrap
#`(1 2 (unsyntax-splicing '(3 4) '(5)) 6))
'(1 2 3 4 5 6))
(test (unwrap
#`#(1 2 (unsyntax-splicing '(3 4) '(5)) 6))
'#(1 2 3 4 5 6))
(test (unwrap
#`(1 #`(#,(+ 3 4) #,#,(+ 1 1))))
'(1 #`(#,(+ 3 4) #,2)))
(test (unwrap
(syntax-case #'(weird-letrec ([x 1][y 7]) x) ()
[(_ ([v e] ...) . b)
#'(let ()
(define v) ...
. b)]))
'(let () (define x) (define y) x))
(test/exn (syntax-violation #f "bad" 7) &syntax)
(test/exn (syntax-violation 'form "bad" 7) &syntax)
(test/exn (syntax-violation #f "bad" #'7) &syntax)
(test/exn (syntax-violation #f "bad" #'7 8) &syntax)
(test/exn (syntax-violation #f "bad" #'7 #'8) &syntax)
(test/exn (syntax-violation #f "bad" 7 #'8) &syntax)
(test/exn (syntax-violation 'form "bad" #'7 #'8) &syntax)
(test/exn (syntax-violation 'form "bad" 7 #'8) &syntax)
(test/exn (syntax-violation 'form "bad" #'7 8) &syntax)
(test/exn (syntax-violation 'form "bad" 7 8) &syntax)
(test/exn (syntax-violation "form" "bad" 7) &syntax)
(test/exn (syntax-violation "form" "bad" 7 8) &syntax)
(test (condition-message
(guard (v [#t v])
(syntax-violation 'apple "bad" 'worm)))
"bad")
(test (condition-who
(guard (v [#t v])
(syntax-violation 'apple "bad" 'worm)))
'apple)
(test (condition-who
(guard (v [#t v])
(syntax-violation "apple" "bad" 'worm)))
"apple")
(test (who-condition?
(guard (v [#t v])
(syntax-violation #f "bad" 'worm)))
#f)
(test (condition-who
(guard (v [#t v])
(syntax-violation #f "bad" #'worm)))
'worm)
(test (syntax-violation-form
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm))))
'(worm))
(test (syntax-violation-subform
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm))))
#f)
(test (syntax-violation-subform
(guard (v [#t v])
(syntax-violation 'apple "bad" '(worm) '((another)))))
'((another)))
))