;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010,
-;;;; 2011, 2012 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define-module (test-suite test-syntax)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 local-eval)
#:use-module (test-suite lib))
(define exception:too-many-args
"too many arguments")
+(define exception:wrong-number-of-values
+ '(wrong-number-of-args . "number of (values)|(arguments)"))
(define exception:zero-expression-sequence
"sequence of zero expressions")
(eval '(let () (define x #t))
(interaction-environment))))
+(with-test-prefix "top-level define-values"
+
+ (pass-if "zero values"
+ (eval '(begin (define-values () (values))
+ #t)
+ (interaction-environment)))
+
+ (pass-if-equal "one value"
+ 1
+ (eval '(begin (define-values (x) 1)
+ x)
+ (interaction-environment)))
+
+ (pass-if-equal "two values"
+ '(2 3)
+ (eval '(begin (define-values (x y) (values 2 3))
+ (list x y))
+ (interaction-environment)))
+
+ (pass-if-equal "three values"
+ '(4 5 6)
+ (eval '(begin (define-values (x y z) (values 4 5 6))
+ (list x y z))
+ (interaction-environment)))
+
+ (pass-if-equal "one value with tail"
+ '(a (b c d))
+ (eval '(begin (define-values (x . y) (values 'a 'b 'c 'd))
+ (list x y))
+ (interaction-environment)))
+
+ (pass-if-equal "two values with tail"
+ '(x y (z w))
+ (eval '(begin (define-values (x y . z) (values 'x 'y 'z 'w))
+ (list x y z))
+ (interaction-environment)))
+
+ (pass-if-equal "just tail"
+ '(1 2 3)
+ (eval '(begin (define-values x (values 1 2 3))
+ x)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 0 values, got 1"
+ exception:wrong-number-of-values
+ (eval '(define-values () 1)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value, got 0"
+ exception:wrong-number-of-values
+ (eval '(define-values (x) (values))
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value, got 2"
+ exception:wrong-number-of-values
+ (eval '(define-values (x) (values 1 2))
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value with tail, got 0"
+ exception:wrong-number-of-values
+ (eval '(define-values (x . y) (values))
+ (interaction-environment)))
+
+ (pass-if-exception "expected 2 value with tail, got 1"
+ exception:wrong-number-of-values
+ (eval '(define-values (x y . z) 1)
+ (interaction-environment)))
+
+ (pass-if "redefinition"
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+
+ ;; The previous values of `floor' and `round' must still be
+ ;; visible at the time the new `floor' and `round' are defined.
+ (eval '(define-values (floor round) (values floor round)) m)
+ (and (eq? (module-ref m 'floor) floor)
+ (eq? (module-ref m 'round) round))))
+
+ (with-test-prefix "missing expression"
+
+ (pass-if-syntax-error "(define-values)"
+ exception:generic-syncase-error
+ (eval '(define-values)
+ (interaction-environment)))))
+
+(with-test-prefix "internal define-values"
+
+ (pass-if "zero values"
+ (let ()
+ (define-values () (values))
+ #t))
+
+ (pass-if-equal "one value"
+ 1
+ (let ()
+ (define-values (x) 1)
+ x))
+
+ (pass-if-equal "two values"
+ '(2 3)
+ (let ()
+ (define-values (x y) (values 2 3))
+ (list x y)))
+
+ (pass-if-equal "three values"
+ '(4 5 6)
+ (let ()
+ (define-values (x y z) (values 4 5 6))
+ (list x y z)))
+
+ (pass-if-equal "one value with tail"
+ '(a (b c d))
+ (let ()
+ (define-values (x . y) (values 'a 'b 'c 'd))
+ (list x y)))
+
+ (pass-if-equal "two values with tail"
+ '(x y (z w))
+ (let ()
+ (define-values (x y . z) (values 'x 'y 'z 'w))
+ (list x y z)))
+
+ (pass-if-equal "just tail"
+ '(1 2 3)
+ (let ()
+ (define-values x (values 1 2 3))
+ x))
+
+ (pass-if-exception "expected 0 values, got 1"
+ exception:wrong-number-of-values
+ (eval '(let ()
+ (define-values () 1)
+ #f)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value, got 0"
+ exception:wrong-number-of-values
+ (eval '(let ()
+ (define-values (x) (values))
+ #f)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value, got 2"
+ exception:wrong-number-of-values
+ (eval '(let ()
+ (define-values (x) (values 1 2))
+ #f)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 1 value with tail, got 0"
+ exception:wrong-number-of-values
+ (eval '(let ()
+ (define-values (x . y) (values))
+ #f)
+ (interaction-environment)))
+
+ (pass-if-exception "expected 2 value with tail, got 1"
+ exception:wrong-number-of-values
+ (eval '(let ()
+ (define-values (x y . z) 1)
+ #f)
+ (interaction-environment)))
+
+ (with-test-prefix "missing expression"
+
+ (pass-if-syntax-error "(define-values)"
+ exception:generic-syncase-error
+ (eval '(let ()
+ (define-values)
+ #f)
+ (interaction-environment)))))
+
(with-test-prefix "set!"
(with-test-prefix "missing or extra expressions"
(unreachable))))))
(r 'outer))
#t)))
+
+(with-test-prefix "syntax-rules"
+
+ (pass-if-equal "custom ellipsis within normal ellipsis"
+ '((((a x) (a y) (a …))
+ ((b x) (b y) (b …))
+ ((c x) (c y) (c …)))
+ (((a x) (b x) (c x))
+ ((a y) (b y) (c y))
+ ((a …) (b …) (c …))))
+ (let ()
+ (define-syntax foo
+ (syntax-rules ()
+ ((_ y ...)
+ (syntax-rules … ()
+ ((_ x …)
+ '((((x y) ...) …)
+ (((x y) …) ...)))))))
+ (define-syntax bar (foo x y …))
+ (bar a b c)))
+
+ (pass-if-equal "normal ellipsis within custom ellipsis"
+ '((((a x) (a y) (a z))
+ ((b x) (b y) (b z))
+ ((c x) (c y) (c z)))
+ (((a x) (b x) (c x))
+ ((a y) (b y) (c y))
+ ((a z) (b z) (c z))))
+ (let ()
+ (define-syntax foo
+ (syntax-rules … ()
+ ((_ y …)
+ (syntax-rules ()
+ ((_ x ...)
+ '((((x y) …) ...)
+ (((x y) ...) …)))))))
+ (define-syntax bar (foo x y z))
+ (bar a b c)))
+
+ ;; This test is given in SRFI-46.
+ (pass-if-equal "custom ellipsis is handled hygienically"
+ '((1) 2 (3) (4))
+ (let-syntax
+ ((f (syntax-rules ()
+ ((f ?e)
+ (let-syntax
+ ((g (syntax-rules --- ()
+ ((g (??x ?e) (??y ---))
+ '((??x) ?e (??y) ---)))))
+ (g (1 2) (3 4)))))))
+ (f ---))))
+
+(with-test-prefix "syntax-error"
+
+ (pass-if-syntax-error "outside of macro without args"
+ "test error"
+ (eval '(syntax-error "test error")
+ (interaction-environment)))
+
+ (pass-if-syntax-error "outside of macro with args"
+ "test error x \\(y z\\)"
+ (eval '(syntax-error "test error" x (y z))
+ (interaction-environment)))
+
+ (pass-if-equal "within macro"
+ '(simple-let
+ "expected an identifier but got (z1 z2)"
+ (simple-let ((y (* x x))
+ ((z1 z2) (values x x)))
+ (+ y 1)))
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(let ()
+ (define-syntax simple-let
+ (syntax-rules ()
+ ((_ (head ... ((x . y) val) . tail)
+ body1 body2 ...)
+ (syntax-error
+ "expected an identifier but got"
+ (x . y)))
+ ((_ ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...)
+ val ...))))
+ (define (foo x)
+ (simple-let ((y (* x x))
+ ((z1 z2) (values x x)))
+ (+ y 1)))
+ foo)
+ (interaction-environment))
+ (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (list who what form)))))
+
+(with-test-prefix "syntax-case"
+
+ (pass-if-syntax-error "duplicate pattern variable"
+ '(syntax-case . "duplicate pattern variable")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((a b c d e d f) #f)))
+ (interaction-environment)))
+
+ (with-test-prefix "misplaced ellipses"
+
+ (pass-if-syntax-error "bare ellipsis"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ (... #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis singleton"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis in car"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((... . _) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "ellipsis in cdr"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((_ . ...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "two ellipses in the same list"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((x ... y ...) #f)))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "three ellipses in the same list"
+ '(syntax-case . "misplaced ellipsis")
+ (eval '(lambda (e)
+ (syntax-case e ()
+ ((x ... y ... z ...) #f)))
+ (interaction-environment)))))
+
+(with-test-prefix "with-ellipsis"
+
+ (pass-if-equal "simple"
+ '(a 1 2 3)
+ (let ()
+ (define-syntax define-quotation-macros
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (macro-name head-symbol) ...)
+ #'(begin (define-syntax macro-name
+ (lambda (x)
+ (with-ellipsis …
+ (syntax-case x ()
+ ((_ x …)
+ #'(quote (head-symbol x …)))))))
+ ...)))))
+ (define-quotation-macros (quote-a a) (quote-b b))
+ (quote-a 1 2 3)))
+
+ (pass-if-equal "disables normal ellipsis"
+ '(a ...)
+ (let ()
+ (define-syntax foo
+ (lambda (x)
+ (with-ellipsis …
+ (syntax-case x ()
+ ((_)
+ #'(quote (a ...)))))))
+ (foo)))
+
+ (pass-if-equal "doesn't affect ellipsis for generated code"
+ '(a b c)
+ (let ()
+ (define-syntax quotation-macro
+ (lambda (x)
+ (with-ellipsis …
+ (syntax-case x ()
+ ((_)
+ #'(lambda (x)
+ (syntax-case x ()
+ ((_ x ...)
+ #'(quote (x ...))))))))))
+ (define-syntax kwote (quotation-macro))
+ (kwote a b c)))
+
+ (pass-if-equal "propagates into syntax binders"
+ '(a b c)
+ (let ()
+ (with-ellipsis …
+ (define-syntax kwote
+ (lambda (x)
+ (syntax-case x ()
+ ((_ x …)
+ #'(quote (x …))))))
+ (kwote a b c))))
+
+ (pass-if-equal "works with local-eval"
+ 5
+ (let ((env (with-ellipsis … (the-environment))))
+ (local-eval '(syntax-case #'(a b c d e) ()
+ ((x …)
+ (length #'(x …))))
+ env))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
+;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)
+;;; End: