#! /bin/sh
exec ../src/sizzle -qs $0 $*
!#
;; test/r5rs.scm -- tests from R5RS
;;
;; Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;
;; This 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 software 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 package; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.  

;; All tests in this file are originally from R5RS, where they served
;; as examples.

;; Load the test framework.

(load "test-suite.scm")

(begin-section "primitive expression types")

(begin-sub-section "variable references")
(define var-1 28)
(pass-if var-1 28 =)

(begin-sub-section "literal expressions")
(pass-if (quote a) 'a eq?)
(pass-if (quote #(a b c)) '#(a b c) equal?)
(pass-if (quote (+ 1 2)) '(+ 1 2) equal?)
(pass-if '() '() eq?)
(pass-if ''a ''a equal?)
(pass-if '"abc" "abc" equal?)
(pass-if "abc" "abc" equal?)
(pass-if '145932 145932 =)
(pass-if '#t #t eq?)
(pass-if #t #t eq?)

(begin-sub-section "procedure calls")
(pass-if (+ 3 4) 7 =)
(pass-if ((if #f + *) 3 4) 12 =)

(begin-sub-section "procedures")
(pass-if (procedure? (lambda (x) (+ x x))) #t eq?)
(pass-if ((lambda (x) (+ x x)) 4) 8 =)
(define reverse-subtract
  (lambda (x y) (- y x)))
(pass-if (reverse-subtract 7 10) 3 =)
(define add4
  (let ((x 4))
    (lambda (y) (+ x y))))
(pass-if (add4 6) 10 =)
(pass-if ((lambda x x) 3 4 5 6) '(3 4 5 6) equal?)
(pass-if ((lambda (x y . z) z) 3 4 5 6) '(5 6) equal?)

(begin-sub-section "conditionals")
(pass-if (if (> 3 2) 'yes 'no) 'yes eq?)
(pass-if (if (> 2 3) 'yes 'no) 'no eq?)
(pass-if (if (> 3 2) (- 3 2) (+ 3 2)) 1 =)

(begin-sub-section "assignments")
(define var-2 2)
(pass-if (+ var-2 1) 3 =)
(set! var-2 4)
(pass-if (+ var-2 1) 5 =)

(begin-section "derived expression types")

(begin-sub-section "conditionals")
(pass-if (cond ((> 3 2) 'greater)
	       ((< 3 2) 'less))
	 'greater eq?)
(pass-if (cond ((> 3 3) 'greater)
	       ((< 3 3) 'less)
	       (else 'equal))
	 'equal eq?)
(pass-if (cond ((assv 'b '((a 1) (b 2))) => cadr)
	       (else #f))
	 2 =)

(pass-if (case (* 2 3)
	   ((2 3 5 7) 'prime)
	   ((1 4 6 8 9) 'composite))
	 'composite eq?)
(pass-if (case (car '(c d))
	   ((a) 'a)
	   ((b) 'b))
	 (if #f #f) eq?)
(pass-if (case (car '(c d))
	   ((a e i o u) 'vowel)
	   ((w y) 'semivowel)
	   (else 'consonant))
	 'consonant eq?)

(pass-if (and (= 2 2) (> 2 1)) #t eq?)
(pass-if (and (= 2 2) (< 2 1)) #f eq?)
(pass-if (and 1 2 'c '(f g)) '(f g) equal?)
(pass-if (and) #t eq?)

(pass-if (or (= 2 2) (> 2 1)) #t eq?)
(pass-if (or (= 2 2) (< 2 1)) #t eq?)
(pass-if (or #f #f #f) #f eq?)
(pass-if (or (memq 'b '(a b c)) (/ 3 0)) '(b c) equal?)
(pass-if (or) #f eq?)

(begin-sub-section "binding constructs")
(pass-if (let ((x 2) (y 3)) (* x y)) 6 =)
(pass-if (let ((x 2) (y 3))
	   (let ((x 7)
		 (z (+ x y)))
	     (* z x))) 35 =)

(pass-if (let ((x 2) (y 3))
	   (let* ((x 7)
		  (z (+ x y)))
	     (* z x))) 70 =)

(pass-if (letrec ((even?
		   (lambda (n)
		     (if (zero? n)
			 #t
			 (odd? (- n 1)))))
		  (odd?
		   (lambda (n)
		     (if (zero? n)
			 #f
			 (even? (- n 1))))))
	   (even? 88)) #t eq?)

(begin-section "sequencing")

(begin-sub-section "begin")
(define begin-var 0)
(pass-if (begin (set! begin-var 5)
		(+ begin-var 1)) 6 =)

(begin-section "iteration")

(begin-sub-section "do")
(pass-if (do ((vec (make-vector 5))
	      (i 0 (+ i 1)))
	     ((= i 5) vec)
	   (vector-set! vec i i)) '#(0 1 2 3 4) equal?)
(pass-if (let ((x '(1 3 5 7 9)))
	   (do ((x x (cdr x))
		(sum 0 (+ sum (car x))))
	       ((null? x) sum))) 25 =)

(begin-sub-section "named let")
(pass-if (let loop ((numbers '(3 -2 1 6 -5))
		    (nonneg '())
		    (neg '()))
	   (cond ((null? numbers) (list nonneg neg))
		 ((>= (car numbers) 0)
		  (loop (cdr numbers)
			(cons (car numbers) nonneg)
			neg))
		 ((< (car numbers) 0)
		  (loop (cdr numbers)
			nonneg
			(cons (car numbers) neg)))))
	 '((6 1 3) (-5 -2)) equal?)

(begin-section "delayed evaluation")
;; FIXME: add test

(begin-section "quasiquotation")

(begin-sub-section "quasiquote / unquote / unquote-splicing")
(pass-if `(list ,(+ 1 2) 4) '(list 3 4) equal?)
(pass-if (let ((name 'a)) `(list ,name ',name))
	 '(list a (quote a)) equal?)
(pass-if `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)
	 '(a 3 4 5 6 b) equal?)
(pass-if `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))
	 '((foo 7) . cons) equal?)
(pass-if `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)
	 '#(10 5 2 4 3 8) equal?)
(pass-if `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
	 '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
	 equal?)
(pass-if (let ((name1 'x)
	       (name2 'y))
	   `(a `(b ,,name1 ,',name2 d) e))
	 '(a `(b ,x ,'y d) e) 
	 equal?)
(pass-if (quasiquote (list (unquote (+ 1 2)) 4)) '(list 3 4) equal?)

(begin-section "definitions")

(begin-sub-section "toplevel definitions")
(define add3
  (lambda (x) (+ x 3)))
(pass-if (add3 3) 6 =)
(define =first= car)
(pass-if (=first= '(1 2)) 1 =)

(begin-sub-section "internal definitions")
(pass-if (let ((x 5))
	   (define foo (lambda (y) (bar x y)))
	   (define bar (lambda (a b) (+ (* a b) a)))
	   (foo (+ x 3)))
	 45 =)

(begin-section "equivalence predicates")

(begin-sub-section "eqv?")
(pass-if (eqv? 'bla 'bla) (string=? (symbol->string 'bla)
				    (symbol->string 'bla)) eq?)
(pass-if (eqv? 'bla 'bar) (string=? (symbol->string 'bla)
				    (symbol->string 'bar)) eq?)
(pass-if (eqv? 'a 'a) #t eq?)
(pass-if (eqv? 'a 'b) #f eq?)
(pass-if (eqv? 2 2) #t eq?)
(pass-if (eqv? '() '()) #t eq?)
(pass-if (eqv? 100000000 100000000) #t eq?)
(pass-if (eqv? (cons 1 2) (cons 1 2)) #f eq?)
(pass-if (eqv? (lambda () 1) (lambda () 2)) #f eq?)
(pass-if (eqv? #f 'nil) #f eq?)
(pass-if (let ((p (lambda (x) x)))
	   (eqv? p p)) #t eq?)

(begin-sub-section "eq?")
(pass-if (eq? 'a 'a) #t eq?)
(pass-if (eq? (list 'a) (list 'a)) #f eq?)
(pass-if (eq? '() '()) #t eq?)
(pass-if (eq? car car) #t eq?)
(pass-if (let ((x '(a))) (eq? x x)) #t eq?)
(pass-if (let ((x '#())) (eq? x x)) #t eq?)
(pass-if (let ((p (lambda (x) x))) (eq? p p)) #t eq?)

(begin-sub-section "equal?")
(pass-if (equal? 'a 'a) #t eq?)
(pass-if (equal? '(a) '(a)) #t eq?)
(pass-if (equal? '(a (b) c) '(a (b) c)) #t eq?)
(pass-if (equal? "abc" "abc") #t eq?)
(pass-if (equal? 2 2) #t eq?)
(pass-if (equal? (make-vector 5 'a) (make-vector 5 'a)) #t eq?)

(begin-section "numbers")

(begin-sub-section "number predicates")
;(pass-if (complex? 3+4i) #t eq?)
(pass-if (complex? 3) #t eq?)
(pass-if (real? 3) #t eq?)
;(pass-if (real? -2.5+0.0i) #t eq?)
;(pass-if (real? #e1e10) #t eq?)
;(pass-if (rational? 6/10) #t eq?)
;(pass-if (rational? 6/3) #t eq?)
;(pass-if (integer? 3+0i) #t eq?)
;(pass-if (integer? 3.0) #t eq?)
;(pass-if (integer? 8/4) #t eq?)

(begin-sub-section "min / max")
(pass-if (exact? (max 3 4)) #t eq?)
; Commented out until I figure out whether r4rstest is right or the
; following stuff...  (mgrabmue/2000-11-08)
;;(pass-if (inexact? (max 3.9 4)) #f eq?)

(begin-sub-section "basic arithmetic")
(pass-if (+ 3 4) 7 =)
(pass-if (+ 3) 3 =)
(pass-if (+) 0 =)
(pass-if (* 4) 4 =)
(pass-if (*) 1 =)
(pass-if (- 3 4) -1 =)
(pass-if (- 3 4 5) -6 =)
(pass-if (- 3) -3 =)
;(pass-if (/ 3 4 5) 3/20 =)
;(pass-if (/ 3) 1/3 =)

(begin-sub-section "abs")
(pass-if (abs -7) 7 =)

(begin-sub-section "division")
(pass-if (modulo 13 4) 1 =)
(pass-if (remainder 13 4) 1 =)
;(pass-if (modulo -13 4) 3 =)
(pass-if (remainder -13 4) -1 =)
;(pass-if (modulo 13 -4) -3 =)
(pass-if (remainder 13 -4) 1 =)
(pass-if (modulo -13 -4) -1 =)
(pass-if (remainder -13 -4) -1 =)
;(pass-if (inexact? (remainder -13 -4.0)) #t eq?)

(begin-sub-section "gcd / lcm")
(pass-if (gcd 32 -36) 4 =)
(pass-if (gcd) 0 =)
(pass-if (lcm 32 -36) 288 =)
;(pass-if (inexact? (lcm 32.0 -36)) #t eq?)
(pass-if (lcm) 1 =)

(begin-sub-section "rounding")
(pass-if (floor -4.3) -5.0 =)
(pass-if (ceiling -4.3) -4.0 =)
(pass-if (truncate -4.3) -4.0 =)
(pass-if (round -4.3) -4.0 =)

(pass-if (floor 3.5) 3.0 =)
(pass-if (ceiling 3.5) 4.0 =)
; FIXME: The following barfs.
;(pass-if (truncate 3.5) 3.0 =)
(pass-if (round 3.5) 4.0 =)

;(pass-if (round 7/2) 4 =)
;(pass-if (exact? (round 7/2)) #t eq?)
(pass-if (round 7) 7 =)

(begin-sub-section "numerical input and output")
(pass-if (let ((number 2342)
	       (radix 16))
	   (eqv? number
		 (string->number (number->string number radix) radix)))
	 #t eq?)
(pass-if (let ((number 2342)
	       (radix 8))
	   (eqv? number
		 (string->number (number->string number radix) radix)))
	 #t eq?)
(pass-if (let ((number 2342)
	       (radix 10))
	   (eqv? number
		 (string->number (number->string number radix) radix)))
	 #t eq?)
(pass-if (let ((number 2342)
	       (radix 2))
	   (eqv? number
		 (string->number (number->string number radix) radix)))
	 #t eq?)
(pass-if (string->number "100") 100 =)
(pass-if (string->number "100" 16) 256 =)
;(pass-if (string->number "1e2") 100.0 =)
;(pass-if (string->number "15##") 1500 =)

(begin-section "booleans")

(begin-sub-section "boolean literals")
(pass-if #t #t eq?)
(pass-if #f #f eq?)
(pass-if '#f #f eq?)

(begin-sub-section "not")
(pass-if (not #t) #f eq?)
(pass-if (not 3) #f eq?)
(pass-if (not (list 3)) #f eq?)
(pass-if (not #f) #t eq?)
(pass-if (not '()) #f eq?)
(pass-if (not (list)) #f eq?)
(pass-if (not 'nil) #f eq?)

(begin-sub-section "boolean?")
(pass-if (boolean? #f) #t eq?)
(pass-if (boolean? 0) #f eq?)
(pass-if (boolean? '()) #f eq?)

(begin-section "pairs and lists")

(begin-sub-section "list literals")
(pass-if '(a b c d e) '(a . (b . (c . (d . (e . ()))))) equal?)
(pass-if '(a b c . d) '(a . (b . (c . d))) equal?)

(begin-sub-section "pair?")
(pass-if (pair? '(1 . b)) #t eq?)
(pass-if (pair? '(a b c)) #t eq?)
(pass-if (pair? '()) #f eq?)
(pass-if (pair? '#(a b)) #f eq?)

(begin-sub-section "cons")
(pass-if (cons 'a '()) '(a) equal?)
(pass-if (cons '(a) '(b c d)) '((a) b c d) equal?)
(pass-if (cons "a" '(b c)) '("a" b c) equal?)
(pass-if (cons 'a 3) '(a . 3) equal?)
(pass-if (cons '(a b) 'c) '((a b) . c) equal?)

(begin-sub-section "car")
(pass-if (car '(a b c)) 'a eq?)
(pass-if (car '((a) b c d)) '(a) equal?)
(pass-if (car '(1 . 2)) 1 eqv?)

(begin-sub-section "cdr")
(pass-if (cdr '((a) b c d)) '(b c d) equal?)
(pass-if (cdr '(1 . 2)) 2 eqv?)

(begin-sub-section "list?")
(pass-if (list? '(a b c)) #t eq?)
(pass-if (list? '()) #t eq?)
(pass-if (list? '(a . b)) #f eq?)
(pass-if (let ((x (list 'a))) (set-cdr! x x) (list? x)) #f eq?)

(begin-sub-section "list")
(pass-if (list 'a (+ 3 4) 'c) '(a 7 c) equal?)
(pass-if (list) '() eq?)

(begin-sub-section "length")
(pass-if (length '(a b c)) 3 =)
(pass-if (length '(a (b) (c d e))) 3 =)
(pass-if (length '()) 0 =)

(begin-sub-section "append")
(pass-if (append '(x) '(y)) '(x y) equal?)
(pass-if (append '(a) '(b c d)) '(a b c d) equal?)
(pass-if (append '(a (b)) '((c))) '(a (b) (c)) equal?)
(pass-if (append '(a b) '(c . d)) '(a b c . d) equal?)
(pass-if (append '() 'a) 'a eq?)

(begin-sub-section "reverse")
(pass-if (reverse '(a b c)) '(c b a) equal?)
(pass-if (reverse '(a (b c) d (e (f)))) '((e (f)) d (b c) a) equal?)

(begin-sub-section "list-ref")
(pass-if (list-ref '(a b c d) 2) 'c eq?)
(pass-if (list-ref '(a b c d) (inexact->exact (round 1.8))) 'c eq?)

(begin-sub-section "memq / memv / member")
(pass-if (memq 'a '(a b c)) '(a b c) equal?)
(pass-if (memq 'b '(a b c)) '(b c) equal?)
(pass-if (memq 'a '(b c d)) #f eq?)
(pass-if (memq (list 'a) '(b (a) c)) #f eq?)
(pass-if (member (list 'a) '(b (a) c)) '((a) c) equal?)
(pass-if (memv 101 '(100 101 102)) '(101 102) equal?)

(begin-sub-section "assq / assv / assoc")
(define ass-e '((a 1) (b 2) (c 3)))
(pass-if (assq 'a ass-e) '(a 1) equal?)
(pass-if (assq 'b ass-e) '(b 2) equal?)
(pass-if (assq 'd ass-e) #f eq?)
(pass-if (assq (list 'a) '(((a)) ((b)) ((c)))) #f eq?)
(pass-if (assoc (list 'a) '(((a)) ((b)) ((c)))) '((a)) equal?)
(pass-if (assv 5 '((2 3) (5 7) (11 13))) '(5 7) equal?)

(begin-section "symbols")

(begin-sub-section "symbol literals")
; FIXME: Test valid symbols here!
(begin-sub-section "symbol?")
(pass-if (symbol? 'foob) #t eq?)
(pass-if (symbol? '!@#$%^&*) #t eq?)
(pass-if (symbol? '_123456789123456789123456789) #t eq?)
(pass-if (symbol? 'this_is_a_rather_long_symbol_but_should_nevertheless_parse_correctly_in_sizzle_because_sizzle_tries_not_to_impose_artificial_limits_on_anything_at_least_if_possible) #t eq?)

(begin-sub-section "symbol->string")
(pass-if (symbol->string 'foobar) "foobar" string=?)
(pass-if (symbol->string (string->symbol "baz")) "baz" string=?)

(begin-sub-section "string->symbol")
(pass-if (string->symbol "frob") 'frob eq?)
(pass-if (string->symbol (symbol->string 'baz)) 'baz eq?)

(begin-section "character")

(begin-sub-section "character literals")
(pass-if (char? #\a) #t eq?)
(pass-if (char? #\A) #t eq?)
(pass-if (char? #\() #t eq?)
(pass-if (char? #\ ) #t eq?)
(pass-if (char? #\newline) #t eq?)
(pass-if (char? #\space) #t eq?)

(begin-sub-section "char?")
(pass-if (char? #\f) #t eq?)

(begin-sub-section "character comparison")
(pass-if (char=? #\a #\a) #t eq?)
(pass-if (char=? #\a #\b) #f eq?)
(pass-if (char<? #\a #\a) #f eq?)
(pass-if (char<? #\a #\b) #t eq?)
(pass-if (char<=? #\a #\a) #t eq?)
(pass-if (char<=? #\a #\b) #t eq?)
(pass-if (char>? #\a #\a) #f eq?)
(pass-if (char>? #\b #\a) #t eq?)
(pass-if (char>=? #\a #\a) #t eq?)
(pass-if (char>=? #\b #\a) #t eq?)

(begin-sub-section "case-insensitive character comparison")
(pass-if (char-ci=? #\A #\a) #t eq?)
(pass-if (char-ci=? #\a #\B) #f eq?)
(pass-if (char-ci<? #\A #\a) #f eq?)
(pass-if (char-ci<? #\A #\b) #t eq?)
(pass-if (char-ci<=? #\a #\A) #t eq?)
(pass-if (char-ci<=? #\a #\B) #t eq?)
(pass-if (char-ci>? #\A #\a) #f eq?)
(pass-if (char-ci>? #\b #\A) #t eq?)
(pass-if (char-ci>=? #\a #\a) #t eq?)
(pass-if (char-ci>=? #\B #\A) #t eq?)

(begin-sub-section "character predicates")
(pass-if (char-alphabetic? #\A) #t eq?)
(pass-if (char-alphabetic? #\0) #f eq?)
(pass-if (char-alphabetic? #\z) #t eq?)
(pass-if (char-alphabetic? #\_) #f eq?)
(pass-if (char-alphabetic? #\space) #f eq?)
(pass-if (char-numeric? #\A) #f eq?)
(pass-if (char-numeric? #\0) #t eq?)
(pass-if (char-numeric? #\z) #f eq?)
(pass-if (char-numeric? #\_) #f eq?)
(pass-if (char-numeric? #\space) #f eq?)
(pass-if (char-whitespace? #\A) #f eq?)
(pass-if (char-whitespace? #\0) #f eq?)
(pass-if (char-whitespace? #\z) #f eq?)
(pass-if (char-whitespace? #\_) #f eq?)
(pass-if (char-whitespace? #\space) #t eq?)
(pass-if (char-upper-case? #\A) #t eq?)
(pass-if (char-upper-case? #\0) #f eq?)
(pass-if (char-upper-case? #\z) #f eq?)
(pass-if (char-upper-case? #\_) #f eq?)
(pass-if (char-upper-case? #\space) #f eq?)
(pass-if (char-lower-case? #\A) #f eq?)
(pass-if (char-lower-case? #\0) #f eq?)
(pass-if (char-lower-case? #\z) #t eq?)
(pass-if (char-lower-case? #\_) #f eq?)
(pass-if (char-lower-case? #\space) #f eq?)

(begin-sub-section "char->integer")
(pass-if (integer? (char->integer #\f)) #t eq?)
(pass-if (integer? (char->integer #\space)) #t eq?)

(begin-sub-section "integer->char")
(pass-if (char? (integer->char 33)) #t eq?)
(pass-if (char? (integer->char 0)) #t eq?)
(pass-if (char? (integer->char 255)) #t eq?)

(begin-sub-section "character conversion")
(pass-if (char? (char-upcase #\a)) #t eq?)
(pass-if (char-upcase #\a) #\A char=?)
(pass-if (char-upcase #\Z) #\Z char=?)
(pass-if (char-upcase #\space) #\space char=?)
(pass-if (char? (char-downcase #\A)) #t eq?)
(pass-if (char-downcase #\A) #\a char=?)
(pass-if (char-downcase #\a) #\a char=?)
(pass-if (char-downcase #\space) #\space char=?)

(begin-section "strings")

(begin-sub-section "string literals")
(pass-if (string? "") #t eq?)
(pass-if (string? "The word \"recursion\" has many meanings.") #t eq?)
(pass-if (string? "\\\"\\\"") #t eq?)

(begin-section "vectors")
(begin-sub-section "vector literals")
(pass-if (vector? '#()) #t eq?)
(pass-if (vector? '#(#() #())) #t eq?)
(pass-if (vector? '#(1 2 3 4)) #t eq?)
(pass-if (vector? '#(foo bar baz frob)) #t eq?)

(begin-section "control features")

(begin-sub-section "predicates")
(pass-if (procedure? car) #t eq?)
(pass-if (procedure? 'car) #f eq?)
(pass-if (procedure? (lambda (x) (* x x))) #t eq?)
(pass-if (procedure? '(lambda (x) (* x x))) #f eq?)
(pass-if (call-with-current-continuation procedure?) #t eq?)

(begin-sub-section "apply")
(pass-if (apply + (list 3 4)) 7 =)
(define compose
  (lambda (f g)
    (lambda args
      (f (apply g args)))))
(pass-if ((compose sqrt *) 12 75) 30 =)

(begin-sub-section "map")
(pass-if (map cadr '((a b) (d e) (g h))) '(b e h) equal?)
(pass-if (map (lambda (n) (expt n n)) '(1 2 3 4 5))
	 '(1 4 27 256 3125) equal?)

(begin-sub-section "for-each")
(pass-if (let ((v (make-vector 5)))
	   (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v)
	 '#(0 1 4 9 16) equal?)

(begin-sub-section "force")
(pass-if (force (delay (+ 1 2))) 3 =)
(pass-if (let ((p (delay (+ 1 2))))
	   (list (force p) (force p))) '(3 3) equal?)
(define a-stream
  (letrec ((next (lambda (n)
		   (cons n (delay (next (+ n 1)))))))
    (next 0)))
(define head car)
(define tail
  (lambda (stream) (force (cdr stream))))
(pass-if (head (tail (tail a-stream))) 2 =)
(define count 0)
(define p
  (delay (begin (set! count (+ count 1))
		(if (> count x)
		    count
		    (force p)))))
(define x 5)
(pass-if (force p) 6 =)
(pass-if (begin (set! x 10)
		(force p)) 6 =)

(begin-sub-section "call/cc")
(pass-if (call-with-current-continuation
	  (lambda (exit)
	    (for-each (lambda (x)
			(if (negative? x)
			    (exit x)))
		      '(54 0 27 -3 245 19))
	    #t)) -3 =)
(define list-length
  (lambda (obj)
    (call-with-current-continuation
     (lambda (return)
       (letrec ((r
		 (lambda (obj)
		   (cond ((null? obj) 0)
			 ((pair? obj)
			  (+ (r (cdr obj)) 1))
			 (else (return #f))))))
	 (r obj))))))
(pass-if (list-length '(1 2 3 4)) 4 =)
(pass-if (list-length '(a b . c)) #f eq?)

(begin-sub-section "multiple values")
(pass-if (call-with-values (lambda () (values 4 5)) (lambda (a b) b)) 5 =)
(pass-if (call-with-values * -) -1 =)

(begin-sub-section "eval and environments")
(pass-if (eval '(* 7 3) (scheme-report-environment 5)) 21 =)
(pass-if (let ((f (eval '(lambda (f x) (f x x)) (null-environment 5))))
	   (f + 10)) 20 =)
(pass-if (eval '(- 10 9 2) (interaction-environment)) -1 =)

(test-summary)
