;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA


(define exception:bad-bindings
  (cons 'misc-error "^bad bindings"))
(define exception:duplicate-bindings
  (cons 'misc-error "^duplicate bindings"))
(define exception:bad-body
  (cons 'misc-error "^bad body"))
(define exception:bad-formals
  (cons 'misc-error "^bad formals"))
(define exception:duplicate-formals
  (cons 'misc-error "^duplicate formals"))
(define exception:bad-var
  (cons 'misc-error "^bad variable"))
(define exception:bad/missing-clauses
  (cons 'misc-error "^bad or missing clauses"))
(define exception:missing/extra-expr
  (cons 'misc-error "^missing or extra expression"))


(with-test-prefix "expressions"

  (with-test-prefix "missing or extra expression"

    ;; R5RS says:
    ;; *Note:* In many dialects of Lisp, the empty combination, (),
    ;; is a legitimate expression.  In Scheme, combinations must
    ;; have at least one subexpression, so () is not a syntactically
    ;; valid expression.

    ;; Fixed on 2001-3-3
    (pass-if-exception "empty parentheses \"()\""
      exception:missing/extra-expr
      ())))

(with-test-prefix "quote"
  #t)

(with-test-prefix "quasiquote"

  (with-test-prefix "unquote"

    (pass-if "repeated execution"
      (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
	(and (equal? (foo) '(1)) (equal? (foo) '(2))))))

  (with-test-prefix "unquote-splicing"

    (pass-if-exception "extra arguments"
      exception:missing/extra-expr
      (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))

(with-test-prefix "begin"

  (pass-if "legal (begin)"
    (begin)
    #t)

  (expect-fail-exception "illegal (begin)"
    exception:bad-body
    (if #t (begin))
    #t))

(with-test-prefix "lambda"

  (with-test-prefix "bad formals"

    (pass-if-exception "(lambda)"
      exception:bad-formals
      (lambda))

    (pass-if-exception "(lambda . \"foo\")"
      exception:bad-formals
      (lambda . "foo"))

    (pass-if-exception "(lambda \"foo\")"
      exception:bad-formals
      (lambda "foo"))

    (pass-if-exception "(lambda \"foo\" #f)"
      exception:bad-formals
      (eval '(lambda "foo" #f)
	    (interaction-environment)))

    (pass-if-exception "(lambda (x 1) 2)"
      exception:bad-formals
      (lambda (x 1) 2))

    (pass-if-exception "(lambda (1 x) 2)"
      exception:bad-formals
      (lambda (1 x) 2))

    (pass-if-exception "(lambda (x \"a\") 2)"
      exception:bad-formals
      (lambda (x "a") 2))

    (pass-if-exception "(lambda (\"a\" x) 2)"
      exception:bad-formals
      (lambda ("a" x) 2)))

  (with-test-prefix "duplicate formals"

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x) 1)"
      exception:duplicate-formals
      (lambda (x x) 1))

    ;; Fixed on 2001-3-3
    (pass-if-exception "(lambda (x x x) 1)"
      exception:duplicate-formals
      (lambda (x x x) 1)))

  (with-test-prefix "bad body"

    (pass-if-exception "(lambda ())"
      exception:bad-body
      (lambda ()))))

(with-test-prefix "let"

  (with-test-prefix "bindings"

    (pass-if-exception "late binding"
      exception:unbound-var
      (let ((x 1) (y x)) y)))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let)"
      exception:bad-bindings
      (let))

    (pass-if-exception "(let 1)"
      exception:bad-bindings
      (let 1))

    (pass-if-exception "(let (x))"
      exception:bad-bindings
      (let (x)))

    ;; FIXME:  Wouldn't one rather expect a 'bad bindings' error?
    ;; (Even although the body is bad as well...)
    (pass-if-exception "(let ((x)))"
      exception:bad-body
      (let ((x))))

    (pass-if-exception "(let (x) 1)"
      exception:bad-bindings
      (let (x) 1))

    (pass-if-exception "(let ((x)) 3)"
      exception:bad-bindings
      (let ((x)) 3))

    (pass-if-exception "(let ((x 1) y) x)"
      exception:bad-bindings
      (let ((x 1) y) x))

    (pass-if-exception "(let ((1 2)) 3)"
      exception:bad-var
      (eval '(let ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(let ((x 1) (x 2)) x)"
      exception:duplicate-bindings
      (let ((x 1) (x 2)) x)))

  (with-test-prefix "bad body"

    (pass-if-exception "(let ())"
      exception:bad-body
      (let ()))

    (pass-if-exception "(let ((x 1)))"
      exception:bad-body
      (let ((x 1))))))

(with-test-prefix "named let"

  (with-test-prefix "initializers"

    (pass-if "evaluated in outer environment"
      (let ((f -))
	(eqv? (let f ((n (f 1))) n) -1))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let x (y))"
      exception:bad-bindings
      (let x (y))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let x ())"
      exception:bad-body
      (let x ()))

    (pass-if-exception "(let x ((y 1)))"
      exception:bad-body
      (let x ((y 1))))))

(with-test-prefix "let*"

  (with-test-prefix "bindings"

    (pass-if "(let* ((x 1) (x 2)) ...)"
      (let* ((x 1) (x 2))
	(= x 2)))

    (pass-if "(let* ((x 1) (x x)) ...)"
      (let* ((x 1) (x x))
	(= x 1))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(let*)"
      exception:bad-bindings
      (let*))

    (pass-if-exception "(let* 1)"
      exception:bad-bindings
      (let* 1))

    (pass-if-exception "(let* (x))"
      exception:bad-bindings
      (let* (x)))

    (pass-if-exception "(let* (x) 1)"
      exception:bad-bindings
      (let* (x) 1))

    (pass-if-exception "(let* ((x)) 3)"
      exception:bad-bindings
      (let* ((x)) 3))

    (pass-if-exception "(let* ((x 1) y) x)"
      exception:bad-bindings
      (let* ((x 1) y) x))

    (pass-if-exception "(let* x ())"
      exception:bad-bindings
      (eval '(let* x ())
	    (interaction-environment)))

    (pass-if-exception "(let* x (y))"
      exception:bad-bindings
      (eval '(let* x (y))
	    (interaction-environment)))

    (pass-if-exception "(let* ((1 2)) 3)"
      exception:bad-var
      (eval '(let* ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "bad body"

    (pass-if-exception "(let* ())"
      exception:bad-body
      (let* ()))

    (pass-if-exception "(let* ((x 1)))"
      exception:bad-body
      (let* ((x 1))))))

(with-test-prefix "letrec"

  (with-test-prefix "bindings"

    (pass-if-exception "initial bindings are undefined"
      exception:unbound-var
      (let ((x 1))
	(letrec ((x 1) (y x)) y))))

  (with-test-prefix "bad bindings"

    (pass-if-exception "(letrec)"
      exception:bad-bindings
      (letrec))

    (pass-if-exception "(letrec 1)"
      exception:bad-bindings
      (letrec 1))

    (pass-if-exception "(letrec (x))"
      exception:bad-bindings
      (letrec (x)))

    (pass-if-exception "(letrec (x) 1)"
      exception:bad-bindings
      (letrec (x) 1))

    (pass-if-exception "(letrec ((x)) 3)"
      exception:bad-bindings
      (letrec ((x)) 3))

    (pass-if-exception "(letrec ((x 1) y) x)"
      exception:bad-bindings
      (letrec ((x 1) y) x))

    (pass-if-exception "(letrec x ())"
      exception:bad-bindings
      (eval '(letrec x ())
	    (interaction-environment)))

    (pass-if-exception "(letrec x (y))"
      exception:bad-bindings
      (eval '(letrec x (y))
	    (interaction-environment)))

    (pass-if-exception "(letrec ((1 2)) 3)"
      exception:bad-var
      (eval '(letrec ((1 2)) 3)
	    (interaction-environment))))

  (with-test-prefix "duplicate bindings"

    (pass-if-exception "(letrec ((x 1) (x 2)) x)"
      exception:duplicate-bindings
      (letrec ((x 1) (x 2)) x)))

  (with-test-prefix "bad body"

    (pass-if-exception "(letrec ())"
      exception:bad-body
      (letrec ()))

    (pass-if-exception "(letrec ((x 1)))"
      exception:bad-body
      (letrec ((x 1))))))

(with-test-prefix "if"

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(if)"
      exception:missing/extra-expr
      (eval '(if)
	    (interaction-environment)))

    (pass-if-exception "(if 1 2 3 4)"
      exception:missing/extra-expr
      (eval '(if 1 2 3 4)
	    (interaction-environment)))))

(with-test-prefix "cond"

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(cond)"
      exception:bad/missing-clauses
      (cond))

    (pass-if-exception "(cond #t)"
      exception:bad/missing-clauses
      (cond #t))

    (pass-if-exception "(cond 1)"
      exception:bad/missing-clauses
      (cond 1))

    (pass-if-exception "(cond 1 2)"
      exception:bad/missing-clauses
      (cond 1 2))

    (pass-if-exception "(cond 1 2 3)"
      exception:bad/missing-clauses
      (cond 1 2 3))

    (pass-if-exception "(cond 1 2 3 4)"
      exception:bad/missing-clauses
      (cond 1 2 3 4))

    (pass-if-exception "(cond ())"
      exception:bad/missing-clauses
      (cond ()))

    (pass-if-exception "(cond () 1)"
      exception:bad/missing-clauses
      (cond () 1))

    (pass-if-exception "(cond (1) 1)"
      exception:bad/missing-clauses
      (cond (1) 1))))

(with-test-prefix "cond =>"

  (with-test-prefix "else is handled correctly"

    (pass-if "else =>"
      (let ((=> 'foo))
	(eq? (cond (else =>)) 'foo)))

    (pass-if "else => identity"
      (let* ((=> 'foo))
	(eq? (cond (else => identity)) identity))))

  (with-test-prefix "bad formals"

    (pass-if-exception "=> (lambda (x 1) 2)"
      exception:bad-formals
      (cond (1 => (lambda (x 1) 2))))))

(with-test-prefix "case"

  (with-test-prefix "bad or missing clauses"

    (pass-if-exception "(case)"
      exception:bad/missing-clauses
      (case))

    (pass-if-exception "(case . \"foo\")"
      exception:bad/missing-clauses
      (case . "foo"))

    (pass-if-exception "(case 1)"
      exception:bad/missing-clauses
      (case 1))

    (pass-if-exception "(case 1 . \"foo\")"
      exception:bad/missing-clauses
      (case 1 . "foo"))

    (pass-if-exception "(case 1 \"foo\")"
      exception:bad/missing-clauses
      (case 1 "foo"))

    (pass-if-exception "(case 1 ())"
      exception:bad/missing-clauses
      (case 1 ()))

    (pass-if-exception "(case 1 (\"foo\"))"
      exception:bad/missing-clauses
      (case 1 ("foo")))

    (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
      exception:bad/missing-clauses
      (case 1 ("foo" "bar")))

    ;; According to R5RS, the following one is syntactically correct.
    ;; (pass-if-exception "(case 1 (() \"bar\"))"
    ;;   exception:bad/missing-clauses
    ;;   (case 1 (() "bar")))

    (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
      exception:bad/missing-clauses
      (case 1 ((2) "bar") . "foo"))

    (pass-if-exception "(case 1 (else #f) ((1) #t))"
      exception:bad/missing-clauses
      (case 1 ((2) "bar") (else)))

    (pass-if-exception "(case 1 (else #f) . \"foo\")"
      exception:bad/missing-clauses
      (case 1 (else #f) . "foo"))

    (pass-if-exception "(case 1 (else #f) ((1) #t))"
      exception:bad/missing-clauses
      (case 1 (else #f) ((1) #t)))))

(with-test-prefix "define"

  (with-test-prefix "currying"

    (pass-if "(define ((foo)) #f)"
      (define ((foo)) #t)
      ((foo))))

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(define)"
      exception:missing/extra-expr
      (define))))

(with-test-prefix "set!"

  (with-test-prefix "missing or extra expressions"

    (pass-if-exception "(set!)"
      exception:missing/extra-expr
      (eval '(set!)
	    (interaction-environment)))

    (pass-if-exception "(set! 1)"
      exception:missing/extra-expr
      (eval '(set! 1)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 2 3)"
      exception:missing/extra-expr
      (eval '(set! 1 2 3)
	    (interaction-environment))))

  (with-test-prefix "bad variable"

    (pass-if-exception "(set! \"\" #t)"
      exception:bad-var
      (eval '(set! "" #t)
	    (interaction-environment)))

    (pass-if-exception "(set! 1 #t)"
      exception:bad-var
      (eval '(set! 1 #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #t #f)"
      exception:bad-var
      (eval '(set! #t #f)
	    (interaction-environment)))

    (pass-if-exception "(set! #f #t)"
      exception:bad-var
      (eval '(set! #f #t)
	    (interaction-environment)))

    (pass-if-exception "(set! #\space #f)"
      exception:bad-var
      (eval '(set! #\space #f)
	    (interaction-environment)))))

(with-test-prefix "quote"

  (with-test-prefix "missing or extra expression"

    (pass-if-exception "(quote)"
      exception:missing/extra-expr
      (eval '(quote)
	    (interaction-environment)))

    (pass-if-exception "(quote a b)"
      exception:missing/extra-expr
      (eval '(quote a b)
	    (interaction-environment)))))

(with-test-prefix "while"
  
  (define (unreachable)
    (error "unreachable code has been reached!"))
  
  ;; an environment with no bindings at all
  (define empty-environment
    (make-module 1))
  
  ;; Return a new procedure COND which when called (COND) will return #t the
  ;; first N times, then #f, then any further call is an error.  N=0 is
  ;; allowed, in which case #f is returned by the first call.
  (define (make-iterations-cond n)
    (lambda ()
      (cond ((not n)
	     (error "oops, condition re-tested after giving false"))
	    ((= 0 n)
	     (set! n #f)
	     #f)
	    (else
	     (set! n (1- n))
	     #t))))
  

  (pass-if-exception "too few args" exception:wrong-num-args
    (while))
  
  (with-test-prefix "empty body"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(let ((cond (make-iterations-cond n)))
	  (while (cond)))
	#t)))
  
  (pass-if "initially false"
    (while #f
      (unreachable))
    #t)
  
  (with-test-prefix "in empty environment"
    
    (pass-if "empty body"
      (eval `(,while #f)
	    empty-environment)
      #t)
    
    (pass-if "initially false"
      (eval `(,while #f
	       #f)
	    empty-environment)
      #t)
    
    (pass-if "iterating"
      (let ((cond (make-iterations-cond 3)))
	(eval `(,while (,cond)
		 123 456)
	      empty-environment))
      #t))
  
  (with-test-prefix "iterations"
    (do ((n 0 (1+ n)))
	((> n 5))
      (pass-if n
	(let ((cond (make-iterations-cond n))
	      (i    0))
	  (while (cond)
	    (set! i (1+ i)))
	  (= i n)))))
  
  (with-test-prefix "break"
    
    (pass-if-exception "too many args" exception:wrong-num-args
      (while #t
	(break 1)))
    
    (with-test-prefix "from cond"
      (pass-if "first"
	(while (begin
		 (break)
		 (unreachable))
	  (unreachable))
	#t)
      
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       #t
		       (begin
			 (break)
			 (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))
    
    (with-test-prefix "from body"
      (pass-if "first"
	(while #t
	  (break)
	  (unreachable))
	#t)
      
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while #t
	      (if (not (cond))
		  (begin
		    (break)
		    (unreachable)))
	      (set! i (1+ i)))
	    (= i n)))))
    
    (pass-if "from nested"
      (while #t
	(let ((outer-break break))
	  (while #t
	    (outer-break)
	    (unreachable)))
	(unreachable))
      #t))
  
  (with-test-prefix "continue"
    
    (pass-if-exception "too many args" exception:wrong-num-args
      (while #t
	(continue 1)))
    
    (with-test-prefix "from cond"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (if (cond)
		       (begin
			 (set! i (1+ i))
			 (continue)
			 (unreachable))
		       #f)
	      (unreachable))
	    (= i n)))))
    
    (with-test-prefix "from body"
      (do ((n 0 (1+ n)))
	  ((> n 5))
	(pass-if n
	  (let ((cond (make-iterations-cond n))
		(i    0))
	    (while (cond)
	      (set! i (1+ i))
	      (continue)
	      (unreachable))
	    (= i n)))))
    
    (pass-if "from nested"
      (let ((cond (make-iterations-cond 3)))
	(while (cond)
	  (let ((outer-continue continue))
	    (while #t
	      (outer-continue)
	      (unreachable)))))
      #t)))