367 lines
11 KiB
Scheme
367 lines
11 KiB
Scheme
#!r6rs
|
|
|
|
(library (tests r6rs syntax-case)
|
|
(export run-syntax-case-tests)
|
|
(import (for (rnrs) run expand)
|
|
(rename (only (rnrs base) cons) (cons kons)) ; for free-identifier=?
|
|
(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)])))
|
|
|
|
;; Different frmo the report to avoid set-car!
|
|
(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)
|
|
;; (test/exn (set! p.car 15) &syntax) ; not a runtime exception
|
|
|
|
(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/exn (rec 5 (lambda (x) x)) &syntax) ; not a runtime exception
|
|
|
|
(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/exn (let ([a 3] [a 4]) (+ a a)) &syntax)
|
|
|
|
(test (let-syntax
|
|
([dolet (lambda (x)
|
|
(syntax-case x ()
|
|
[(_ b)
|
|
#'(let ([a 3] [b 4]) (+ a b))]))])
|
|
(dolet a))
|
|
7)
|
|
|
|
;; check that it's ok as an expression:
|
|
(test 6
|
|
(let-syntax ([foo
|
|
(syntax-rules ()
|
|
[(_)
|
|
(let-syntax ([bar
|
|
(syntax-rules ()
|
|
[(_) 5])])
|
|
(bar))])])
|
|
(+ 1 (foo))))
|
|
|
|
#;
|
|
(test/exn (let ([else #f])
|
|
(case 0 [else (write "oops")]))
|
|
&syntax)
|
|
|
|
(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 (syntax-case #'(... x) ()
|
|
[a (syntax->datum #'a)])
|
|
'x)
|
|
(test (syntax-case #'(... ...) ()
|
|
[a (syntax->datum #'a)])
|
|
'...)
|
|
(test (syntax-case #'(... (other ...)) ()
|
|
[a (syntax->datum #'a)])
|
|
'(other ...))
|
|
(test (syntax-case #'(1 2 3) ()
|
|
[(a ...) (syntax->datum #'((a (... ...)) ...))])
|
|
'((1 ...) (2 ...) (3 ...)))
|
|
(test (syntax-case #'(1 2 3) ()
|
|
[(a b c) (syntax->datum #'(... (a ...)))])
|
|
'(1 ...))
|
|
(test (syntax-case #'(1 2 3) ()
|
|
[(a b c) (syntax->datum #'(... (... (a) b)))])
|
|
'(... (1) 2))
|
|
|
|
(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) ;; see PLT bug report #10210
|
|
|
|
(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)
|
|
|
|
;; Check wrapping:
|
|
(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)))
|
|
|
|
|
|
;;
|
|
))
|
|
|