;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
;;;; Copyright (C) 2000, 2001 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
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; 
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

(define-module (test-suite test-eval)
  :use-module (test-suite lib)
  :use-module (ice-9 documentation))


(define exception:bad-expression
  (cons 'syntax-error "Bad expression"))


;;;
;;; miscellaneous
;;;

(define (documented? object)
  (not (not (object-documentation object))))


;;;
;;; memoization
;;;

(with-test-prefix "memoization"

  (with-test-prefix "copy-tree"

    (pass-if "(#t . #(#t))"
      (let* ((foo (cons #t (vector #t)))
             (bar (copy-tree foo)))
        (vector-set! (cdr foo) 0 #f)
        (equal? bar '(#t . #(#t)))))

    (pass-if-exception "circular lists in forms"
      exception:bad-expression
      (let ((foo (list #f)))
        (set-cdr! foo foo)
        (copy-tree foo))))

  (pass-if "transparency"
    (let ((x '(begin 1)))
      (eval x (current-module))
      (equal? '(begin 1) x))))


;;;
;;; eval
;;;

(with-test-prefix "evaluator"

  (with-test-prefix "symbol lookup"

    (with-test-prefix "top level"

      (with-test-prefix "unbound"

	(pass-if-exception "variable reference"
	  exception:unbound-var
	  x)

	(pass-if-exception "procedure"
	  exception:unbound-var
	  (x)))))

  (with-test-prefix "parameter error"

    ;; This is currently a bug in guile:
    ;; Macros are accepted as function parameters.
    ;; Functions that 'apply' macros are rewritten!!!

    (expect-fail-exception "macro as argument"
      exception:wrong-type-arg
      (let ((f (lambda (p a b) (p a b))))
	(f and #t #t)))

    (expect-fail-exception "passing macro as parameter"
      exception:wrong-type-arg
      (let* ((f (lambda (p a b) (p a b)))
	     (foo (procedure-source f)))
	(f and #t #t)
	(equal? (procedure-source f) foo)))

    ))

;;;
;;; apply
;;;

(with-test-prefix "application"

  (with-test-prefix "wrong number of arguments"

    (pass-if-exception "((lambda () #f) 1)"
      exception:wrong-num-args
      ((lambda () #f) 1))

    (pass-if-exception "((lambda (x) #f))"
      exception:wrong-num-args
      ((lambda (x) #f)))

    (pass-if-exception "((lambda (x) #f) 1 2)"
      exception:wrong-num-args
      ((lambda (x) #f) 1 2))

    (pass-if-exception "((lambda (x y) #f))"
      exception:wrong-num-args
      ((lambda (x y) #f)))

    (pass-if-exception "((lambda (x y) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1))

    (pass-if-exception "((lambda (x y) #f) 1 2 3)"
      exception:wrong-num-args
      ((lambda (x y) #f) 1 2 3))

    (pass-if-exception "((lambda (x . rest) #f))"
      exception:wrong-num-args
      ((lambda (x . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f))"
      exception:wrong-num-args
      ((lambda (x y . rest) #f)))

    (pass-if-exception "((lambda (x y . rest) #f) 1)"
      exception:wrong-num-args
      ((lambda (x y . rest) #f) 1))))

;;;
;;; map
;;;

(with-test-prefix "map"

  ;; Is documentation available?

  (expect-fail "documented?"
    (documented? map))

  (with-test-prefix "argument error"

    (with-test-prefix "non list argument"
      #t)

    (with-test-prefix "different length lists"

      (pass-if-exception "first list empty"
	exception:out-of-range
	(map + '() '(1)))

      (pass-if-exception "second list empty"
	exception:out-of-range
	(map + '(1) '()))

      (pass-if-exception "first list shorter"
	exception:out-of-range
	(map + '(1) '(2 3)))

      (pass-if-exception "second list shorter"
	exception:out-of-range
	(map + '(1 2) '(3)))
    )))

;;;
;;; promises
;;;

(with-test-prefix "promises"

  (with-test-prefix "basic promise behaviour"

    (pass-if "delay gives a promise"
      (promise? (delay 1)))

    (pass-if "force evaluates a promise"
      (eqv? (force (delay (+ 1 2))) 3))

    (pass-if "a forced promise is a promise"
      (let ((p (delay (+ 1 2))))
	(force p)
	(promise? p)))

    (pass-if "forcing a forced promise works"
      (let ((p (delay (+ 1 2))))
	(force p)
	(eqv? (force p) 3)))

    (pass-if "a promise is evaluated once"
      (let* ((x 1)
	     (p (delay (+ x 1))))
	(force p)
	(set! x (+ x 1))
	(eqv? (force p) 2)))

    (pass-if "a promise may call itself"
      (define p
	(let ((x 0))
	  (delay 
	    (begin 
	      (set! x (+ x 1))
	      (if (> x 1) x (force p))))))
      (eqv? (force p) 2))

    (pass-if "a promise carries its environment"
      (let* ((x 1) (p #f))
	(let* ((x 2))
	  (set! p (delay (+ x 1))))
	(eqv? (force p) 3)))

    (pass-if "a forced promise does not reference its environment"
      (let* ((g (make-guardian))
	     (p #f))
	(let* ((x (cons #f #f)))
	  (g x)
	  (set! p (delay (car x))))
	(force p)
	(gc)
	(if (not (equal? (g) (cons #f #f)))
	    (throw 'unresolved)
	    #t))))

  (with-test-prefix "extended promise behaviour"

    (pass-if-exception "forcing a non-promise object is not supported"
      exception:wrong-type-arg
      (force 1))

    (pass-if-exception "implicit forcing is not supported"
      exception:wrong-type-arg
      (+ (delay (* 3 7)) 13))))


;;; eval.test ends here