code:
;;;; alist.test --- tests guile's alists     -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (test-suite lib))

;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
;;;       more thorough, though (maybe overkill? I need it, anyway).
;;;
;;;
;;;       Also: it will fail on the ass*-ref & remove functions.
;;;       Sloppy versions should be added with the current behaviour
;;;       (it's the only set of 'ref functions that won't cause an
;;;       error on an incorrect arg); they aren't actually used anywhere
;;;       so changing's not a big deal.

;;; Misc

(define-macro (pass-if-not str form)
  `(pass-if ,str (not ,form)))

(define (safe-assq-ref alist elt)
  (let ((x (assq elt alist)))
    (if x (cdr x) x)))

(define (safe-assv-ref alist elt)
  (let ((x (assv elt alist)))
    (if x (cdr x) x)))

(define (safe-assoc-ref alist elt)
  (let ((x (assoc elt alist)))
    (if x (cdr x) x)))

;;; Creators, getters
(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
      (b (acons "this" "is" (acons "a" "test" '())))
      (deformed '(a b c d e f g)))
  (pass-if "acons"
	   (and (equal? a '((a . b) (c . d) (e . f)))
		(equal? b '(("this" . "is") ("a" . "test")))))
  (pass-if "sloppy-assq"
	   (let ((x (sloppy-assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assq not"
	   (let ((x (sloppy-assq "this" b)))
	     (not x)))
  (pass-if "sloppy-assv"
	   (let ((x (sloppy-assv 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if "sloppy-assv not"
	   (let ((x (sloppy-assv "this" b)))
	     (not x)))
  (pass-if "sloppy-assoc"
	   (let ((x (sloppy-assoc "this" b)))
	     (and (pair? x)
		  (string=? (cdr x) "is"))))
  (pass-if "sloppy-assoc not"
	   (let ((x (sloppy-assoc "heehee" b)))
	     (not x)))
  (pass-if "assq"
	   (let ((x (assq 'c a)))
	     (and (pair? x)
		  (eq? (car x) 'c)
		  (eq? (cdr x) 'd))))
  (pass-if-exception "assq deformed"
    exception:wrong-type-arg
    (assq 'x deformed))
  (pass-if-not "assq not" (assq 'r a))
  (pass-if "assv"
	   (let ((x (assv 'a a)))
	     (and (pair? x)
		  (eq? (car x) 'a)
		  (eq? (cdr x) 'b))))
  (pass-if-exception "assv deformed"
    exception:wrong-type-arg
    (assv 'x deformed))
  (pass-if-not "assv not" (assq "this" b))

  (pass-if "assoc"
	   (let ((x (assoc "this" b)))
	     (and (pair? x)
		  (string=? (car x) "this")
		  (string=? (cdr x) "is"))))
  (pass-if-exception "assoc deformed"
    exception:wrong-type-arg
    (assoc 'x deformed))
  (pass-if-not "assoc not" (assoc "this isn't" b)))

;;; Refers
(let ((a '((foo bar) (baz quux)))
      (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
      (deformed '(thats a real sloppy assq you got there)))
  (pass-if "assq-ref"
	   (let ((x (assq-ref a 'foo)))
	     (and (list? x)
		  (eq? (car x) 'bar))))

  (pass-if-not "assq-ref not" (assq-ref b "one"))
  (pass-if "assv-ref"
	   (let ((x (assv-ref a 'baz)))
	     (and (list? x)
		  (eq? (car x) 'quux))))

  (pass-if-not "assv-ref not" (assv-ref b "one"))

  (pass-if "assoc-ref"
	   (let ((x (assoc-ref b "one")))
	     (and (list? x)
		  (eq? (car x) 2)
		  (eq? (cadr x) 3))))

  (pass-if-not "assoc-ref not" (assoc-ref a 'testing))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))

    (pass-if-exception "assv-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-ref deformed 'sloppy))

    (pass-if-exception "assoc-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-ref deformed 'sloppy))

    (pass-if-exception "assq-ref deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-ref deformed 'sloppy))))

;;; Setters
(let ((a '((another . silly) (alist . test-case)))
      (b '(("this" "one" "has") ("strings" "!")))
      (deformed '(canada is a cold nation)))
  (pass-if "assq-set!"
	   (begin
	     (set! a (assq-set! a 'another 'stupid))
	     (let ((x (safe-assq-ref a 'another)))
	       (and x
		    (symbol? x) (eq? x 'stupid)))))

  (pass-if "assq-set! add"
	   (begin
	     (set! a (assq-set! a 'fickle 'pickle))
	     (let ((x (safe-assq-ref a 'fickle)))
	       (and x (symbol? x)
		    (eq? x 'pickle)))))

  (pass-if "assv-set!"
	   (begin
	     (set! a (assv-set! a 'another 'boring))
	     (let ((x (safe-assv-ref a 'another)))
		   (and x
			(eq? x 'boring)))))
  (pass-if "assv-set! add"
	   (begin
	     (set! a (assv-set! a 'whistle '(while you work)))
	     (let ((x (safe-assv-ref a 'whistle)))
	       (and x (equal? x '(while you work))))))

  (pass-if "assoc-set!"
	   (begin
	     (set! b (assoc-set! b "this" "has"))
	     (let ((x (safe-assoc-ref b "this")))
	       (and x (string? x)
		    (string=? x "has")))))
  (pass-if "assoc-set! add"
	   (begin
	     (set! b (assoc-set! b "flugle" "horn"))
	     (let ((x (safe-assoc-ref b "flugle")))
	       (and x (string? x)
		    (string=? x "horn")))))

  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))

    (pass-if-exception "assq-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assq-set! deformed 'cold '(very cold)))

    (pass-if-exception "assv-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assv-set! deformed 'canada 'Canada))

    (pass-if-exception "assoc-set! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assv-ref?) (throw 'unsupported))
      (assoc-set! deformed 'canada '(Iceland hence the name)))))

;;; Removers

(let ((a '((a b) (c d) (e boring)))
      (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
      (deformed 1))
  (pass-if "assq-remove!"
	   (begin
	     (set! a (assq-remove! a 'a))
	     (equal? a '((c d) (e boring)))))
  (pass-if "assv-remove!"
	   (begin
	     (set! a (assv-remove! a 'c))
	     (equal? a '((e boring)))))
  (pass-if "assoc-remove!"
	   (begin
	     (set! b (assoc-remove! b "what"))
	     (equal? b '(("could" . "I") ("say" . "here")))))

  (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))

    (pass-if-exception "assq-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assq-remove! deformed 'puddle))

    (pass-if-exception "assv-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assv-remove! deformed 'splashing))

    (pass-if-exception "assoc-remove! deformed"
      exception:wrong-type-arg
      (if (not have-sloppy-assq-remove?) (throw 'unsupported))
      (assoc-remove! deformed 'fun))))


code:
;;;; and-let-star.test --- Tests for Guile and-let-star module. -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-and-let-star)
  #:use-module (test-suite lib)
  #:use-module (ice-9 and-let-star))

;;;
;;; and-let*
;;;

(with-test-prefix "and-let*"

  (pass-if "cond-expand srfi-2"
    (cond-expand (srfi-2 #t)
		 (else   #f)))

  (with-test-prefix "no bindings"

    (pass-if "no result expression (gives #t)"
      (and-let* ()))

    (pass-if "result expression"
      (and-let* ()
	#t))

    (pass-if "two result expressions"
      (and-let* ()
	#f
	#t)))

  (with-test-prefix "one binding"

    (pass-if "no result expression (gives #t)"
      (and-let* ((x 123))))

    (pass-if "result expression"
      (and-let* ((x 123))
	#t))

    (pass-if "result variable"
      (and-let* ((x #t))
	x))

    (pass-if "two result expressions"
      (and-let* ((x 123))
	#f
	#t)))

  (with-test-prefix "one test"

    (pass-if "no result expression (gives #t)"
      (and-let* (( 123))))

    (pass-if "result expression"
      (and-let* (( 123))
	#t))

    (pass-if "two result expressions"
      (and-let* (( 123))
	#f
	#t))))

license: unknown


code:
;;;; arbiters.test --- test arbiters functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-arbiters)
  #:use-module (test-suite lib))

;;;
;;; arbiter display
;;;

(with-test-prefix "arbiter display"
  ;; nothing fancy, just exercise the printing code

  (pass-if "never locked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (display arb port)
      #t))

  (pass-if "locked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (try-arbiter arb)
      (display arb port)
      #t))

  (pass-if "unlocked"
    (let ((arb  (make-arbiter "foo"))
	  (port (open-output-string)))
      (try-arbiter arb)
      (release-arbiter arb)
      (display arb port)
      #t)))

;;;
;;; try-arbiter
;;;

(with-test-prefix "try-arbiter"

  (pass-if "lock"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)))

  (pass-if "already locked"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (not (try-arbiter arb))))

  (pass-if "already locked twice"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (try-arbiter arb)
      (not (try-arbiter arb)))))

;;;
;;; release-arbiter
;;;

(with-test-prefix "release-arbiter"

  (pass-if "lock"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)))

  (pass-if "never locked"
    (let ((arb (make-arbiter "foo")))
      (not (release-arbiter arb))))

  (pass-if "never locked twice"
    (let ((arb (make-arbiter "foo")))
      (release-arbiter arb)
      (not (release-arbiter arb))))

  (pass-if "already unlocked"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)
      (not (release-arbiter arb))))

  (pass-if "already unlocked twice"
    (let ((arb (make-arbiter "foo")))
      (try-arbiter arb)
      (release-arbiter arb)
      (release-arbiter arb)
      (not (release-arbiter arb)))))


code:
;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

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

;;;
;;; miscellaneous
;;;

(define (run-tests name-proc test-proc arg-sets)
  (for-each
   (lambda (arg-set)
     (pass-if (apply name-proc arg-set)
       (apply test-proc arg-set)))
   arg-sets))

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

(define fixnum-bit
  (inexact->exact (round (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))))

(define fixnum-min most-negative-fixnum)
(define fixnum-max most-positive-fixnum)

(with-test-prefix "bit-extract"

  (pass-if "documented?"
    (documented? bit-extract))

  (with-test-prefix "extract from zero"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 1 0)
      (list 0 1 2 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit -1) 0)
      (list 0 1 (+ fixnum-bit  0) 0)
      (list 0 2 (+ fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit  0) 0)
      (list 0 1 (+ fixnum-bit  1) 0)
      (list 0 2 (+ fixnum-bit  2) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list 0 0 (+ fixnum-bit  1) 0)
      (list 0 1 (+ fixnum-bit  2) 0)
      (list 0 2 (+ fixnum-bit  3) 0)
      (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 0)
      (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 0)
      (list 0 (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list 0 (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-max"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 1 1)
      (list fixnum-max 1 2 1)
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit -1) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  0) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  1) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit  0) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  1) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  2) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-max 0 (+ fixnum-bit  1) (ash fixnum-max  0))
      (list fixnum-max 1 (+ fixnum-bit  2) (ash fixnum-max -1))
      (list fixnum-max 2 (+ fixnum-bit  3) (ash fixnum-max -2))
      (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 1)
      (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 0)
      (list fixnum-max (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list fixnum-max (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-max + 1"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 1 0)
      (list (+ fixnum-max 1) 1 2 0)
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit  0) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit  1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit  2) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  2) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1) 0)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (+ fixnum-max 1) 0 (+ fixnum-bit  1) (ash 1 (- fixnum-bit 1)))
      (list (+ fixnum-max 1) 1 (+ fixnum-bit  2) (ash 1 (- fixnum-bit 2)))
      (list (+ fixnum-max 1) 2 (+ fixnum-bit  3) (ash 1 (- fixnum-bit 3)))
      (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 2)
      (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0) 1)
      (list (+ fixnum-max 1) (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1) 0)
      (list (+ fixnum-max 1) (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2) 0))))

  (with-test-prefix "extract from fixnum-min"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 1 0)
      (list fixnum-min 1 2 0)
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit  0) 1)
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit  1) 1)
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit  2) 1)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  1) (ash 3 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3)
            (- (ash 1	(- fixnum-bit 1)) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2)
            (- (ash 1	(- fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1	(- fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1	(- fixnum-bit 1)) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit  0) (ash 1 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  1) (ash 3 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  2) (ash 7 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2)
            (- (ash 1	fixnum-bit) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1	fixnum-bit) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1	fixnum-bit) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  1)
            (- (ash 1	fixnum-bit) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list fixnum-min 0 (+ fixnum-bit  1) (ash  3 (- fixnum-bit 1)))
      (list fixnum-min 1 (+ fixnum-bit  2) (ash  7 (- fixnum-bit 2)))
      (list fixnum-min 2 (+ fixnum-bit  3) (ash 15 (- fixnum-bit 3)))
      (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1)
            (- (ash 1 (+ fixnum-bit 1)) 2))
      (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit  0)
            (- (ash 1 (+ fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  0) (+ fixnum-bit fixnum-bit  1)
            (- (ash 1 (+ fixnum-bit 1)) 1))
      (list fixnum-min (+ fixnum-bit  1) (+ fixnum-bit fixnum-bit  2)
            (- (ash 1 (+ fixnum-bit 1)) 1)))))

  (with-test-prefix "extract from fixnum-min - 1"

    (run-tests
     (lambda (a b c d)
       (string-append "single bit " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 1 1)
      (list (- fixnum-min 1) 1 2 1)
      (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
      (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit  0) 0)
      (list (- fixnum-min 1) (+ fixnum-bit  0) (+ fixnum-bit  1) 1)
      (list (- fixnum-min 1) (+ fixnum-bit  1) (+ fixnum-bit  2) 1)))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit -1)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 0 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  0)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  1)
            (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 (- fixnum-bit 1)) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit  0)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  1)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  2)
            (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 fixnum-bit) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  1) (- (ash 1 fixnum-bit) 1))))

    (run-tests
     (lambda (a b c d)
       (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
     (lambda (a b c d)
       (= (bit-extract a b c) d))
     (list
      (list (- fixnum-min 1) 0 (+ fixnum-bit  1)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 1))))
      (list (- fixnum-min 1) 1 (+ fixnum-bit  2)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
      (list (- fixnum-min 1) 2 (+ fixnum-bit  3)
            (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
      (list (- fixnum-min 1) (+ fixnum-bit -2)
            (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 3))
      (list (- fixnum-min 1) (+ fixnum-bit -1)
            (+ fixnum-bit fixnum-bit  0) (- (ash 1 (+ fixnum-bit 1)) 2))
      (list (- fixnum-min 1) (+ fixnum-bit  0)
            (+ fixnum-bit fixnum-bit  1) (- (ash 1 (+ fixnum-bit 1)) 1))
      (list (- fixnum-min 1) (+ fixnum-bit  1)
            (+ fixnum-bit fixnum-bit  2) (- (ash 1 (+ fixnum-bit 1)) 1))))))


code:
;;;; c-api.test --- complementary test suite for the c-api     -*- scheme -*-
;;;; MDJ 990915 <djurfeldt@nada.kth.se>
;;;;
;;;; 	Copyright (C) 1999, 2006 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define srcdir (cdr (assq 'srcdir %guile-build-info)))

(define (egrep string filename)
  (zero? (system (string-append "egrep '" string "' " filename " >/dev/null"))))

(define (seek-offset-test dirname)
  (let ((dir (opendir dirname)))
    (do ((filename (readdir dir) (readdir dir)))
	((eof-object? filename))
      (if (and
	   (eqv? (string-ref filename (- (string-length filename) 1)) #\c)
	   (eqv? (string-ref filename (- (string-length filename) 2)) #\.))
	  (let ((file (string-append dirname "/" filename)))
	    (if (and (file-exists? file)
		     (egrep "SEEK_(SET|CUR|END)" file)
		     (not (egrep "unistd.h" file)))
		(fail file)))))))

;;; A rough conservative test to check that all source files
;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.
;;;
;;; If this test start to trigger without reason, we just modify it
;;; to be more precise.
(with-test-prefix "SEEK_XXX => #include <unistd.h>"
  (if (file-exists? srcdir)
      (seek-offset-test srcdir)))


code:
CC = gcc
CFLAGS = -g `guile-config compile`

all: strings

strings: strings.o testlib.o
	${CC} ${CFLAGS} ${LDFLAGS} -o strings strings.o testlib.o \
		`guile-config link`

strings.o: strings.c testlib.h
testlib.o: testlib.c testlib.h

clean:
	rm -f strings
	rm -f *.o

path: test-suite/tests/c-api/Makefile


code:
[NOTE: this code is no longer used -- for now these tests are in the
 standalone directory.  What'll happen longer-term is uncertain...]

This directory contains tests for Guile's C API.  At the moment, the
test suite doesn't have any way to run these automatically --- we need
to 1) figure out how to run the compiler, and 2) figure out how to
integrate results from C tests into the test suite statistics.

Nonetheless, it's better to have this code accumulating here than
someplace else where nobody can find it.

path: test-suite/tests/c-api/README


code:
/* NOTE: this code was never being run.  The same tests have been
   migrated to standalone/test-gh.c */

/* strings.c --- test the Guile C API's string handling functions
   Jim Blandy <jimb@red-bean.com> --- August 1999  */

#include <guile/gh.h>

#include "testlib.h"

static int
string_equal (SCM str, char *lit)
{
  int len = strlen (lit);

  return (SCM_LENGTH (str) == len
	  && ! memcmp (SCM_ROCHARS (str), lit, len));
}

void
test_gh_set_substr ()
{
  test_context_t cx = test_enter_context ("gh_set_substr");
  SCM string;

  string = gh_str02scm ("Free, darnit!");
  test_pass_if ("make a string", gh_string_p (string));

  gh_set_substr ("dammit", string, 6, 6);
  test_pass_if ("gh_set_substr from literal",
		string_equal (string, "Free, dammit!"));

  /* Make sure that we can use the string itself as a source.

     I guess this behavior isn't really visible, since the GH API
     doesn't provide any direct access to the string contents.  But I
     think it should, eventually.  You can't write efficient string
     code if you have to copy the string just to look at it.  */

  /* Copy a substring to an overlapping region to its right.  */
  gh_set_substr (SCM_CHARS (string), string, 4, 6);
  test_pass_if ("gh_set_substr shifting right",
		string_equal (string, "FreeFree, it!"));

  string = gh_str02scm ("Free, darnit!");
  test_pass_if ("make another string", gh_string_p (string));

  /* Copy a substring to an overlapping region to its left.  */
  gh_set_substr (SCM_CHARS (string) + 6, string, 2, 6);
  test_pass_if ("gh_set_substr shifting right",
		string_equal (string, "Frdarnitrnit!"));

  test_restore_context (cx);
}

void
main_prog (int argc, char *argv[])
{
  test_context_t strings = test_enter_context ("strings.c");

  test_gh_set_substr ();

  test_restore_context (strings);

  exit (test_summarize ());
}

int
main (int argc, char *argv[])
{
  gh_enter (argc, argv, main_prog);
  return 0;
}


code:
/* testlib.c --- reporting test results
   Jim Blandy <jimb@red-bean.com> --- August 1999 */

#include <stdlib.h>
#include <stdio.h>

#include "testlib.h"

/* Dying.  */

static void
fatal (char *message)
{
  fprintf (stderr, "%s\n", message);
  exit (1);
}

/* Contexts.  */

/* If it gets deeper than this, that's probably an error, right?  */
#define MAX_NESTING 10

int depth = 0;
char *context_name_stack[MAX_NESTING];
int marker;
int context_marker_stack[MAX_NESTING];

test_context_t
test_enter_context (char *name)
{
  if (depth >= MAX_NESTING)
    fatal ("test contexts nested too deeply");

  /* Generate a unique marker value for this context.  */
  marker++;

  context_name_stack[depth] = name;
  context_marker_stack[depth] = marker;

  depth++;

  return marker;
}

void
test_restore_context (test_context_t context)
{
  if (depth <= 0)
    fatal ("attempt to leave outermost context");

  depth--;

  /* Make sure that we're exiting the same context we last entered.  */
  if (context_marker_stack[depth] != context)
    fatal ("contexts not nested properly");
}

/* Reporting results.  */

int count_passes, count_fails;

static void
print_test_name (char *name)
{
  int i;

  for (i = 0; i < depth; i++)
    printf ("%s: ", context_name_stack[i]);

  printf ("%s", name);
}

static void
print_result (char *result, char *name)
{
  printf ("%s: ", result);
  print_test_name (name);
  putchar ('\n');
}

void
test_pass (char *name)
{
  print_result ("PASS", name);
  count_passes++;
}

void
test_fail (char *name)
{
  print_result ("FAIL", name);
  count_fails++;
}

void
test_pass_if (char *name, int condition)
{
  (condition ? test_pass : test_fail) (name);
}

/* Printing a summary.  */

/* Print a summary of the reported test results.  Return zero if
   no failures occurred, one otherwise.  */

int
test_summarize ()
{
  putchar ('\n');

  printf ("passes:      %d\n", count_passes);
  printf ("failures:    %d\n", count_fails);
  printf ("total tests: %d\n", count_passes + count_fails);

  return (count_fails != 0);
}


code:
/* testlib.h --- reporting test results
   Jim Blandy <jimb@red-bean.com> --- August 1999 */

#ifndef TESTLIB_H
#define TESTLIB_H

extern void test_pass (char *name);
extern void test_fail (char *name);
extern void test_pass_if (char *name, int condition);

/* We need a way to keep track of what groups of tests we're currently
   within.  A call to test_enter_context assures that future tests
   will be reported with a name prefixed by NAME, until we call
   test_restore_context with the value it returned.

   Calls to test_enter_context and test_restore_context should be
   properly nested; passing the context around allows them to detect
   mismatches.

   It is the caller's responsibility to free NAME after exiting the
   context.  (This is trivial if you're passing string literals to
   test_enter_context.)  */

typedef int test_context_t;
extern test_context_t test_enter_context (char *name);
extern void test_restore_context (test_context_t context);

#endif /* TESTLIB_H */


code:
;;;; chars.test --- test suite for Guile's char functions    -*- scheme -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
;;;; 	Copyright (C) 2000, 2006 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(use-modules (test-suite lib))

(define exception:wrong-type-to-apply
  (cons 'misc-error "^Wrong type to apply:"))

(with-test-prefix "basic char handling"

  (with-test-prefix "evaluator"

    ;; The following test makes sure that the evaluator distinguishes between
    ;; evaluator-internal instruction codes and characters.
    (pass-if-exception "evaluating chars"
      exception:wrong-type-to-apply
      (eval '(#\0) (interaction-environment)))))

(pass-if "char-is-both? works"
	 (and
	  (not (char-is-both? #\?))
	  (not (char-is-both? #\newline))
	  (char-is-both? #\a)
	  (char-is-both? #\Z)
	  (not (char-is-both? #\1))))


code:
;;;; common-list.test --- tests guile's common list functions -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-common-list)
  #:use-module (test-suite lib)
  #:use-module (ice-9 documentation)
  #:use-module (ice-9 common-list))

;;;
;;; miscellaneous
;;;

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

;;;
;;; intersection
;;;

(with-test-prefix "intersection"

  (pass-if "documented?"
    (documented? intersection))

  (pass-if "both arguments empty"
    (eq? (intersection '() '()) '()))

  (pass-if "first argument empty"
    (eq? (intersection '() '(1)) '()))

  (pass-if "second argument empty"
    (eq? (intersection '(1) '()) '()))

  (pass-if "disjoint arguments"
    (eq? (intersection '(1) '(2)) '()))

  (pass-if "equal arguments"
    (equal? (intersection '(1) '(1)) '(1)))

  (pass-if "reverse argument order"
    (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3)))

  (pass-if "multiple matches in first list"
    (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3)))

  (pass-if "multiple matches in second list"
    (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3)))

  (pass-if "mixed arguments"
    (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8)))

  )

;;;
;;; set-difference
;;;

(with-test-prefix "set-difference"

  (pass-if "documented?"
    (documented? set-difference))

  (pass-if "both arguments empty"
    (eq? (set-difference '() '()) '()))

  (pass-if "first argument empty"
    (eq? (set-difference '() '(1)) '()))

  (pass-if "second argument empty"
    (equal? (set-difference '(1) '()) '(1)))

  (pass-if "disjoint arguments"
    (equal? (set-difference '(1) '(2)) '(1)))

  (pass-if "equal arguments"
    (eq? (set-difference '(1) '(1)) '()))

  (pass-if "reverse argument order"
    (eq? (set-difference '(1 2 3) '(3 2 1)) '()))

  (pass-if "multiple matches in first list"
    (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '()))

  (pass-if "multiple matches in second list"
    (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '()))

  (pass-if "mixed arguments"
    (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10)))

  )

;;;
;;; remove-if
;;;

(with-test-prefix "remove-if"

  (pass-if "documented?"
    (documented? remove-if))

  (pass-if "empty list, remove all"
    (eq? (remove-if (lambda (x) #t) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (remove-if (lambda (x) #f) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (remove-if odd? '(1 2 3 4)) '(2 4)))

  )

;;;
;;; remove-if-not
;;;

(with-test-prefix "remove-if-not"

  (pass-if "documented?"
    (documented? remove-if-not))

  (pass-if "empty list, remove all"
    (eq? (remove-if-not (lambda (x) #f) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (remove-if-not (lambda (x) #t) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3)))

  )

;;;
;;; delete-if!
;;;

(with-test-prefix "delete-if!"

  (pass-if "documented?"
    (documented? delete-if!))

  (pass-if "empty list, remove all"
    (eq? (delete-if! (lambda (x) #t) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (delete-if! (lambda (x) #f) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (delete-if! odd? '(1 2 3 4)) '(2 4)))

  )

;;;
;;; delete-if-not!
;;;

(with-test-prefix "delete-if-not!"

  (pass-if "documented?"
    (documented? delete-if-not!))

  (pass-if "empty list, remove all"
    (eq? (delete-if-not! (lambda (x) #f) '()) '()))

  (pass-if "empty list, remove none"
    (eq? (delete-if-not! (lambda (x) #t) '()) '()))

  (pass-if "non-empty list, remove all"
    (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '()))

  (pass-if "non-empty list, remove none"
    (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))

  (pass-if "non-empty list, remove some"
    (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3)))

  )


code:
;;;;                                                          -*- scheme -*-
;;;; continuations.test --- test suite for continutations
;;;;
;;;; Copyright (C) 2003, 2006 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-continuations)
  :use-module (test-suite lib))

(define (block-reentry body)
  (let ((active #f))
    (dynamic-wind
	(lambda ()
	  (if active
	      (throw 'no-reentry)))
	(lambda ()
	  (set! active #t)
	  (body))
	(lambda () #f))))

(define (catch-tag body)
  (catch #t
	 body
	 (lambda (tag . args) tag)))

(define (check-cont)
  (catch-tag
   (lambda ()
     (block-reentry (lambda () (call/cc identity))))))

(define (dont-crash-please)
  (let ((k (check-cont)))
    (if (procedure? k)
	(k 12)
	k)))

(with-test-prefix "continuations"

  (pass-if "throwing to a rewound catch context"
    (eq? (dont-crash-please) 'no-reentry))

  (with-debugging-evaluator

    (pass-if "make a stack from a continuation"
      (stack? (call-with-current-continuation make-stack)))

    (pass-if "get a continuation's stack ID"
      (let ((id (call-with-current-continuation stack-id)))
	(or (boolean? id) (symbol? id))))

    (pass-if "get a continuation's innermost frame"
      (pair? (call-with-current-continuation last-stack-frame))))

)


code:
;;;;                                                          -*- scheme -*-
;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
;;;;
;;;; Copyright (C) 2001, 2006 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., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA

(define-module (test-suite test-dynamic-scope)
  :use-module (test-suite lib))

(define exception:missing-expr
  (cons 'syntax-error "Missing expression"))
(define exception:bad-binding
  (cons 'syntax-error "Bad binding"))
(define exception:duplicate-binding
  (cons 'syntax-error "Duplicate binding"))

(define global-a 0)
(define (fetch-global-a) global-a)

(with-test-prefix "dynamic scope"

  (pass-if "@bind binds"
    (= (@bind ((global-a 1)) (fetch-global-a)) 1))

  (pass-if "@bind unbinds"
    (begin
      (set! global-a 0)
      (@bind ((global-a 1)) (fetch-global-a))
      (= global-a 0)))

  (pass-if-exception "duplicate @binds"
    exception:duplicate-binding
    (eval '(@bind ((a 1) (a 2)) (+ a a))
	  (interaction-environment)))

  (pass-if-exception "@bind missing expression"
    exception:missing-expr
    (eval '(@bind ((global-a 1)))
	  (interaction-environment)))

  (pass-if-exception "@bind bad bindings"
    exception:bad-binding
    (eval '(@bind (a) #f)
	  (interaction-environment)))

  (pass-if-exception "@bind bad bindings"
    exception:bad-binding
    (eval '(@bind ((a)) #f)
	  (interaction-environment)))

  (pass-if "@bind and dynamic-wind"
    (letrec ((co-routine #f)
	     (spawn (lambda (proc)
		      (set! co-routine proc)))
	     (yield (lambda (val)
		      (call-with-current-continuation
		       (lambda (k)
			 (let ((next co-routine))
			   (set! co-routine k)
			   (next val)))))))

      (spawn (lambda (val)
	       (@bind ((global-a 'inside))
	         (yield global-a)
		 (yield global-a))))

      (set! global-a 'outside)
      (let ((inside-a (yield #f)))
	(let ((outside-a global-a))
	  (let ((inside-a2 (yield #f)))
	    (and (eq? inside-a 'inside)
		 (eq? outside-a 'outside)
		 (eq? inside-a2 'inside))))))))


code:
;;;; elisp.test --- tests guile's elisp support     -*- scheme -*-
;;;; Copyright (C) 2002, 2003, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-elisp)
  :use-module (test-suite lib)
  :use-module (ice-9 weak-vector))

;;;
;;; elisp
;;;

(if (defined? '%nil)

    (with-test-prefix "scheme"

      (with-test-prefix "nil value is a boolean"

        (pass-if "boolean?"
          (boolean? %nil))

	)

      (with-test-prefix "nil value is false"

        (pass-if "not"
          (eq? (not %nil) #t))

        (pass-if "if"
	  (if %nil #f #t))

	(pass-if "and"
          (eq? (and %nil #t) #f))

        (pass-if "or"
          (eq? (or %nil #f) #f))

        (pass-if "cond"
          (cond (%nil #f) (else #t)))

	(pass-if "do"
	  (call-with-current-continuation
	    (lambda (exit)
	      (do ((i 0 (+ i 1)))
		  (%nil (exit #f))
		(if (> i 10)
		    (exit #t))))))

	)

      (with-test-prefix "nil value as an empty list"

	(pass-if "list?"
          (list? %nil))

	(pass-if "null?"
          (null? %nil))

	(pass-if "sort"
          (eq? (sort %nil <) %nil))

	)

      (with-test-prefix "lists formed using nil value"

	(pass-if "list?"
          (list? (cons 'a %nil)))

        (pass-if "length of %nil"
          (= (length %nil) 0))

        (pass-if "length"
          (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3))

        (pass-if "length (with backquoted list)"
          (= (length `(a b c . ,%nil)) 3))

	(pass-if "write (%nil)"
          (string=? (with-output-to-string
		      (lambda () (write %nil)))
		    "#nil"))		; Hmmm... should be "()" ?

	(pass-if "display (%nil)"
          (string=? (with-output-to-string
		      (lambda () (display %nil)))
		    "#nil"))		; Ditto.

	(pass-if "write (list)"
          (string=? (with-output-to-string
		      (lambda () (write (cons 'a %nil))))
		    "(a)"))

	(pass-if "display (list)"
          (string=? (with-output-to-string
		      (lambda () (display (cons 'a %nil))))
		    "(a)"))

	(pass-if "assq"
          (and (equal? (assq 1 `((1 one) (2 two) . ,%nil))
		       '(1 one))
	       (equal? (assq 3 `((1 one) (2 two) . ,%nil))
		       #f)))

	(pass-if "assv"
          (and (equal? (assv 1 `((1 one) (2 two) . ,%nil))
		       '(1 one))
	       (equal? (assv 3 `((1 one) (2 two) . ,%nil))
		       #f)))

	(pass-if "assoc"
          (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil))
		       '(1 one))
	       (equal? (assoc 3 `((1 one) (2 two) . ,%nil))
		       #f)))

	(pass-if "with-fluids*"
          (let ((f (make-fluid))
                (g (make-fluid)))
            (with-fluids* (cons f (cons g %nil))
			  '(3 4)
			  (lambda ()
			    (and (eq? (fluid-ref f) 3)
				 (eq? (fluid-ref g) 4))))))

	(pass-if "append!"
	  (let ((a (copy-tree '(1 2 3)))
		(b (copy-tree `(4 5 6 . ,%nil)))
		(c (copy-tree '(7 8 9)))
		(d (copy-tree `(a b c . ,%nil))))
	    (equal? (append! a b c d)
		    `(1 2 3 4 5 6 7 8 9 a b c . ,%nil))))

	(pass-if "last-pair"
	  (equal? (last-pair `(1 2 3 4 5 . ,%nil))
		  (cons 5 %nil)))

	(pass-if "reverse"
	  (equal? (reverse `(1 2 3 4 5 . ,%nil))
		  '(5 4 3 2 1)))	; Hmmm... is this OK, or
					; should it be
					; `(5 4 3 2 1 . ,%nil) ?

	(pass-if "reverse!"
          (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil)))
		  '(5 4 3 2 1)))	; Ditto.

	(pass-if "list-ref"
          (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4))

	(pass-if-exception "list-ref"
	  exception:out-of-range
          (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6))

	(pass-if "list-set!"
	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
	    (list-set! l 4 44)
	    (= (list-ref l 4) 44)))

	(pass-if-exception "list-set!"
	  exception:out-of-range
	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
	    (list-set! l 6 44)
	    (= (list-ref l 6) 44)))

	(pass-if "list-cdr-set!"
	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
	    (and (begin
		   (list-cdr-set! l 4 44)
		   (equal? l '(0 1 2 3 4 . 44)))
		 (begin
		   (list-cdr-set! l 3 `(new . ,%nil))
		   (equal? l `(0 1 2 3 new . ,%nil))))))

	(pass-if-exception "list-cdr-set!"
	  exception:out-of-range
	  (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
	    (list-cdr-set! l 6 44)))

        (pass-if "memq"
          (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil)))

        (pass-if "memv"
          (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil)))

        (pass-if "member"
          (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil)))

	(pass-if "list->vector"
          (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))

	(pass-if "list->vector"
          (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))

	(pass-if "list->weak-vector"
          (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil))))

	(pass-if "sorted?"
	  (and (sorted? `(1 2 3 . ,%nil) <)
	       (not (sorted? `(1 6 3 . ,%nil) <))))

	(pass-if "merge"
          (equal? (merge '(1 4 7 10)
			 (merge `(2 5 8 11 . ,%nil)
				`(3 6 9 12 . ,%nil)
				<)
			 <)
		  `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))

	(pass-if "merge!"
          (equal? (merge! (copy-tree '(1 4 7 10))
			  (merge! (copy-tree `(2 5 8 11 . ,%nil))
				  (copy-tree `(3 6 9 12 . ,%nil))
				  <)
			 <)
		  `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))

	(pass-if "sort"
          (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))

	(pass-if "stable-sort"
          (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))

	(pass-if "sort!"
          (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
		  '(1 3 4 5 8)))

	(pass-if "stable-sort!"
          (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
		  '(1 3 4 5 8)))

	)

      (with-test-prefix "value preservation"

        (pass-if "car"
          (eq? (car (cons %nil 'a)) %nil))

        (pass-if "cdr"
          (eq? (cdr (cons 'a %nil)) %nil))

        (pass-if "vector-ref"
          (eq? (vector-ref (vector %nil) 0) %nil))

	)

      ))

(if (defined? '%nil)
    (use-modules (lang elisp interface)))

(if (defined? '%nil)

    (with-test-prefix "elisp"

      (define (elisp-pass-if expr expected)
	(pass-if (with-output-to-string
		  (lambda ()
		    (write expr)))
		 (let ((calc (with-output-to-string
			      (lambda ()
				(write (eval-elisp expr))))))
		   (string=? calc expected))))

      (elisp-pass-if '(and #f) "#f")
      (elisp-pass-if '(and #t) "#t")
      (elisp-pass-if '(and nil) "#nil")
      (elisp-pass-if '(and t) "#t")
      (elisp-pass-if '(and) "#t")
      (elisp-pass-if '(cond (nil t) (t 3)) "3")
      (elisp-pass-if '(cond (nil t) (t)) "#t")
      (elisp-pass-if '(cond (nil)) "#nil")
      (elisp-pass-if '(cond) "#nil")
      (elisp-pass-if '(if #f 'a 'b) "b")
      (elisp-pass-if '(if #t 'a 'b) "a")
      (elisp-pass-if '(if '() 'a 'b) "b")
      (elisp-pass-if '(if nil 'a 'b) "b")
      (elisp-pass-if '(if nil 1 2 3 4) "4")
      (elisp-pass-if '(if nil 1 2) "2")
      (elisp-pass-if '(if nil 1) "#nil")
      (elisp-pass-if '(if t 1 2) "1")
      (elisp-pass-if '(if t 1) "1")
      (elisp-pass-if '(let (a) a) "#nil")
      (elisp-pass-if '(let* (a) a) "#nil")
      (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2")
      (elisp-pass-if '(memq '() '(())) "(())")
      (elisp-pass-if '(memq '() '(nil)) "(#nil)")
      (elisp-pass-if '(memq '() '(t)) "#nil")
      (elisp-pass-if '(memq nil '(())) "(())")
      (elisp-pass-if '(memq nil '(nil)) "(#nil)")
      (elisp-pass-if '(memq nil (list nil)) "(#nil)")
      (elisp-pass-if '(null '#f) "#t")
      (elisp-pass-if '(null '()) "#t")
      (elisp-pass-if '(null 'nil) "#t")
      (elisp-pass-if '(null nil) "#t")
      (elisp-pass-if '(or 1 2 3) "1")
      (elisp-pass-if '(or nil t nil) "#t")
      (elisp-pass-if '(or nil) "#nil")
      (elisp-pass-if '(or t nil t) "#t")
      (elisp-pass-if '(or t) "#t")
      (elisp-pass-if '(or) "#nil")
      (elisp-pass-if '(prog1 1 2 3) "1")
      (elisp-pass-if '(prog2 1 2 3) "2")
      (elisp-pass-if '(progn 1 2 3) "3")
      (elisp-pass-if '(while nil 1) "#nil")

      (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf")
      (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)")
      (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))")
      ;; NB `lambda' in Emacs is self-quoting, but that's only after
      ;; loading the macro definition of lambda in subr.el.
      (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))")
      (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))")
      (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)")

      (elisp-pass-if '(setq x 3) "3")
      (elisp-pass-if '(defvar x 4) "x")
      (elisp-pass-if 'x "3")

      ))

;;; elisp.test ends here


code:
;;;; environments.test                                    -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2006 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(use-modules (ice-9 documentation))

;;;
;;; miscellaneous
;;;

(define exception:unbound-symbol
  (cons 'misc-error "^Symbol .* not bound in environment"))

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

(define (folder sym val res)
  (cons (cons sym val) res))

(define (make-observer-func)
  (let* ((counter 0))
    (lambda args
      (if (null? args)
	  counter
	  (set! counter (+ counter 1))))))

(define (make-erroneous-observer-func)
  (let* ((func (make-observer-func)))
    (lambda args
      (if (null? args)
	  (func)
	  (begin
	    (func args)
	    (error))))))

;;;
;;; leaf-environments
;;;

(with-test-prefix "leaf-environments"

  (with-test-prefix "leaf-environment?"

    (pass-if "documented?"
      (documented? leaf-environment?))

    (pass-if "non-environment-object"
      (not (leaf-environment? #f))))

  (with-test-prefix "make-leaf-environment"

    (pass-if "documented?"
      (documented? make-leaf-environment))

    (pass-if "produces an environment"
      (environment? (make-leaf-environment)))

    (pass-if "produces a leaf-environment"
      (leaf-environment? (make-leaf-environment)))

    (pass-if "produces always a new environment"
      (not (eq? (make-leaf-environment) (make-leaf-environment)))))

  (with-test-prefix "bound, define, ref, set!, cell"

    (pass-if "symbols are unbound by default"
      (let* ((env (make-leaf-environment)))
	(and (not (environment-bound? env 'a))
	     (not (environment-bound? env 'b))
	     (not (environment-bound? env 'c)))))

    (pass-if "symbol is bound after define"
      (let* ((env (make-leaf-environment)))
	(environment-bound? env 'a)
	(environment-define env 'a #t)
	(environment-bound? env 'a)))

    (pass-if "ref a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-bound? env 'a)
	(environment-bound? env 'b)
	(environment-define env 'a #t)
	(environment-define env 'b #f)
	(and (environment-ref env 'a)
	     (not (environment-ref env 'b)))))

    (pass-if "set! a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(environment-define env 'b #f)
	(environment-ref env 'a)
	(environment-ref env 'b)
	(environment-set! env 'a #f)
	(environment-set! env 'b #t)
	(and (not (environment-ref env 'a))
	     (environment-ref env 'b))))

    (pass-if "get a read-only cell"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(let* ((cell (environment-cell env 'a #f)))
	  (and (cdr cell)
	       (begin
		 (environment-set! env 'a #f)
		 (not (cdr cell)))))))

    (pass-if "a read-only cell gets rebound after define"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(let* ((cell (environment-cell env 'a #f)))
	  (environment-define env 'a #f)
	  (not (eq? (environment-cell env 'a #f) cell)))))

    (pass-if "get a writable cell"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(let* ((readable (environment-cell env 'a #f))
	       (writable (environment-cell env 'a #t)))
	  (and (eq? readable writable)
	       (begin
		 (environment-set! env 'a #f)
		 (not (cdr writable)))
	       (begin
		 (set-cdr! writable #t)
		 (environment-ref env 'a))
	       (begin
		 (set-cdr! (environment-cell env 'a #t) #f)
		 (not (cdr writable)))))))

    (pass-if "a writable cell gets rebound after define"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(let* ((cell (environment-cell env 'a #t)))
	  (environment-define env 'a #f)
	  (not (eq? (environment-cell env 'a #t) cell)))))

    (pass-if-exception "reference an unbound symbol"
      exception:unbound-symbol
      (environment-ref (make-leaf-environment) 'a))

    (pass-if-exception "set! an unbound symbol"
      exception:unbound-symbol
      (environment-set! (make-leaf-environment) 'a #f))

    (pass-if-exception "get a readable cell for an unbound symbol"
      exception:unbound-symbol
      (environment-cell (make-leaf-environment) 'a #f))

    (pass-if-exception "get a writable cell for an unbound symbol"
      exception:unbound-symbol
      (environment-cell (make-leaf-environment) 'a #t)))

  (with-test-prefix "undefine"

    (pass-if "undefine a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(environment-ref env 'a)
	(environment-undefine env 'a)
	(not (environment-bound? env 'a))))

    (pass-if "undefine an already undefined symbol"
      (environment-undefine (make-leaf-environment) 'a)
      #t))

  (with-test-prefix "fold"

    (pass-if "empty environment"
      (let* ((env (make-leaf-environment)))
	(eq? 'success (environment-fold env folder 'success))))

    (pass-if "one symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(equal? '((a . #t)) (environment-fold env folder '()))))

    (pass-if "two symbols"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a #t)
	(environment-define env 'b #f)
	(let ((folded (environment-fold env folder '())))
	  (or (equal? folded '((a . #t) (b . #f)))
	      (equal? folded '((b . #f) (a . #t))))))))

  (with-test-prefix "observe"

    (pass-if "observe an environment"
      (let* ((env (make-leaf-environment)))
	(environment-observe env (make-observer-func))
	#t))

    (pass-if "observe an environment twice"
      (let* ((env (make-leaf-environment))
	     (observer-1 (environment-observe env (make-observer-func)))
	     (observer-2 (environment-observe env (make-observer-func))))
	(not (eq? observer-1 observer-2))))

    (pass-if "definition of an undefined symbol"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func)))
	(environment-observe env func)
	(environment-define env 'a 1)
	(eqv? (func) 1)))

    (pass-if "definition of an already defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-define env 'a 1)
	  (eqv? (func) 1))))

    (pass-if "set!ing of a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-set! env 'a 1)
	  (eqv? (func) 0))))

    (pass-if "undefining a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-undefine env 'a)
	  (eqv? (func) 1))))

    (pass-if "undefining an already undefined symbol"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func)))
	(environment-observe env func)
	(environment-undefine env 'a)
	(eqv? (func) 0)))

    (pass-if "unobserve an active observer"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func))
	     (observer (environment-observe env func)))
	(environment-unobserve observer)
	(environment-define env 'a 1)
	(eqv? (func) 0)))

    (pass-if "unobserve an inactive observer"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func))
	     (observer (environment-observe env func)))
	(environment-unobserve observer)
	(environment-unobserve observer)
	#t)))

  (with-test-prefix "observe-weak"

    (pass-if "observe an environment"
      (let* ((env (make-leaf-environment)))
	(environment-observe-weak env (make-observer-func))
	#t))

    (pass-if "observe an environment twice"
      (let* ((env (make-leaf-environment))
	     (observer-1 (environment-observe-weak env (make-observer-func)))
	     (observer-2 (environment-observe-weak env (make-observer-func))))
	(not (eq? observer-1 observer-2))))

    (pass-if "definition of an undefined symbol"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(environment-define env 'a 1)
	(eqv? (func) 1)))

    (pass-if "definition of an already defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-define env 'a 1)
	  (eqv? (func) 1))))

    (pass-if "set!ing of a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-set! env 'a 1)
	  (eqv? (func) 0))))

    (pass-if "undefining a defined symbol"
      (let* ((env (make-leaf-environment)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-undefine env 'a)
	  (eqv? (func) 1))))

    (pass-if "undefining an already undefined symbol"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(environment-undefine env 'a)
	(eqv? (func) 0)))

    (pass-if "unobserve an active observer"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func))
	     (observer (environment-observe-weak env func)))
	(environment-unobserve observer)
	(environment-define env 'a 1)
	(eqv? (func) 0)))

    (pass-if "unobserve an inactive observer"
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func))
	     (observer (environment-observe-weak env func)))
	(environment-unobserve observer)
	(environment-unobserve observer)
	#t))

    (pass-if "weak observer gets collected"
      (gc)
      (let* ((env (make-leaf-environment))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(gc)
	(environment-define env 'a 1)
	(if (not (eqv? (func) 0))
	    (throw 'unresolved) ; note: conservative scanning
	    #t))))

  (with-test-prefix "erroneous observers"

    (pass-if "update continues after error"
      (let* ((env (make-leaf-environment))
	     (func-1 (make-erroneous-observer-func))
	     (func-2 (make-erroneous-observer-func)))
	(environment-observe env func-1)
	(environment-observe env func-2)
	(catch #t
	  (lambda ()
	    (environment-define env 'a 1)
	    #f)
	  (lambda args
	    (and (eq? (func-1) 1)
		 (eq? (func-2) 1))))))))

;;;
;;; leaf-environment based eval-environments
;;;

(with-test-prefix "leaf-environment based eval-environments"

  (with-test-prefix "eval-environment?"

    (pass-if "documented?"
      (documented? eval-environment?))

    (pass-if "non-environment-object"
      (not (eval-environment? #f)))

    (pass-if "leaf-environment-object"
      (not (eval-environment? (make-leaf-environment)))))

  (with-test-prefix "make-eval-environment"

    (pass-if "documented?"
      (documented? make-eval-environment))

    (let* ((local (make-leaf-environment))
	   (imported (make-leaf-environment)))

      (pass-if "produces an environment"
	(environment? (make-eval-environment local imported)))

      (pass-if "produces an eval-environment"
	(eval-environment? (make-eval-environment local imported)))

      (pass-if "produces always a new environment"
	(not (eq? (make-eval-environment local imported)
		  (make-eval-environment local imported))))))

  (with-test-prefix "eval-environment-local"

    (pass-if "documented?"
      (documented? eval-environment-local))

    (pass-if "returns local"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(eq? (eval-environment-local env) local))))

  (with-test-prefix "eval-environment-imported"

    (pass-if "documented?"
      (documented? eval-environment-imported))

    (pass-if "returns imported"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(eq? (eval-environment-imported env) imported))))

  (with-test-prefix "bound, define, ref, set!, cell"

    (pass-if "symbols are unbound by default"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(and (not (environment-bound? env 'a))
	     (not (environment-bound? env 'b))
	     (not (environment-bound? env 'c)))))

    (with-test-prefix "symbols bound in imported"

      (pass-if "binding is visible"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-bound? env 'a)
	  (environment-define imported 'a #t)
	  (environment-bound? env 'a)))

      (pass-if "ref works"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-bound? env 'a)
	  (environment-define imported 'a #t)
	  (environment-ref env 'a)))

      (pass-if "set! works"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #f)
	  (environment-set! env 'a #t)
	  (environment-ref imported 'a)))

      (pass-if "cells are passed through"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #t)
	  (let* ((imported-cell (environment-cell imported 'a #f))
		 (env-cell (environment-cell env 'a #f)))
	    (eq? env-cell imported-cell)))))

    (with-test-prefix "symbols bound in local"

      (pass-if "binding is visible"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-bound? env 'a)
	  (environment-define local 'a #t)
	  (environment-bound? env 'a)))

      (pass-if "ref works"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define local 'a #t)
	  (environment-ref env 'a)))

      (pass-if "set! works"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define local 'a #f)
	  (environment-set! env 'a #t)
	  (environment-ref local 'a)))

      (pass-if "cells are passed through"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define local 'a #t)
	  (let* ((local-cell (environment-cell local 'a #f))
		 (env-cell (environment-cell env 'a #f)))
	    (eq? env-cell local-cell)))))

    (with-test-prefix "symbols bound in local and imported"

      (pass-if "binding is visible"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-bound? env 'a)
	  (environment-define imported 'a #t)
	  (environment-define local 'a #f)
	  (environment-bound? env 'a)))

      (pass-if "ref works"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #f)
	  (environment-define local 'a #t)
	  (environment-ref env 'a)))

      (pass-if "set! changes local"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #f)
	  (environment-define local 'a #f)
	  (environment-set! env 'a #t)
	  (environment-ref local 'a)))

      (pass-if "set! does not touch imported"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #t)
	  (environment-define local 'a #t)
	  (environment-set! env 'a #f)
	  (environment-ref imported 'a)))

      (pass-if "cells from local are passed through"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define local 'a #t)
	  (let* ((local-cell (environment-cell local 'a #f))
		 (env-cell (environment-cell env 'a #f)))
	    (eq? env-cell local-cell)))))

    (with-test-prefix "defining symbols"

      (pass-if "symbols are bound in local after define"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define env 'a #t)
	  (environment-bound? local 'a)))

      (pass-if "cells in local get rebound after define"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define env 'a #f)
	  (let* ((old-cell (environment-cell local 'a #f)))
	    (environment-define env 'a #f)
	    (let* ((new-cell (environment-cell local 'a #f)))
	      (not (eq? new-cell old-cell))))))

      (pass-if "cells in imported get shadowed after define"
	(let* ((local (make-leaf-environment))
	       (imported (make-leaf-environment))
	       (env (make-eval-environment local imported)))
	  (environment-define imported 'a #f)
	  (environment-define env 'a #t)
	  (environment-ref local 'a))))

    (let* ((local (make-leaf-environment))
	   (imported (make-leaf-environment))
	   (env (make-eval-environment local imported)))

      (pass-if-exception "reference an unbound symbol"
	exception:unbound-symbol
	(environment-ref env 'b))

      (pass-if-exception "set! an unbound symbol"
	exception:unbound-symbol
	(environment-set! env 'b #f))

      (pass-if-exception "get a readable cell for an unbound symbol"
	exception:unbound-symbol
	(environment-cell env 'b #f))

      (pass-if-exception "get a writable cell for an unbound symbol"
	exception:unbound-symbol
	(environment-cell env 'b #t))))

  (with-test-prefix "eval-environment-set-local!"

    (pass-if "documented?"
      (documented? eval-environment-set-local!))

    (pass-if "new binding becomes visible"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-bound? env 'a)
	(environment-define new-local 'a #t)
	(eval-environment-set-local! env new-local)
	(environment-bound? env 'a)))

    (pass-if "existing binding is replaced"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-define old-local 'a #f)
	(environment-ref env 'a)
	(environment-define new-local 'a #t)
	(eval-environment-set-local! env new-local)
	(environment-ref env 'a)))

    (pass-if "undefined binding is removed"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-define old-local 'a #f)
	(environment-ref env 'a)
	(eval-environment-set-local! env new-local)
	(not (environment-bound? env 'a))))

    (pass-if "binding in imported remains shadowed"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-define imported 'a #f)
	(environment-define old-local 'a #f)
	(environment-ref env 'a)
	(environment-define new-local 'a #t)
	(eval-environment-set-local! env new-local)
	(environment-ref env 'a)))

    (pass-if "binding in imported gets shadowed"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-define imported 'a #f)
	(environment-ref env 'a)
	(environment-define new-local 'a #t)
	(eval-environment-set-local! env new-local)
	(environment-ref env 'a)))

    (pass-if "binding in imported becomes visible"
      (let* ((old-local (make-leaf-environment))
	     (new-local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment old-local imported)))
	(environment-define imported 'a #t)
	(environment-define old-local 'a #f)
	(environment-ref env 'a)
	(eval-environment-set-local! env new-local)
	(environment-ref env 'a))))

  (with-test-prefix "eval-environment-set-imported!"

    (pass-if "documented?"
      (documented? eval-environment-set-imported!))

    (pass-if "new binding becomes visible"
      (let* ((local (make-leaf-environment))
	     (old-imported (make-leaf-environment))
	     (new-imported (make-leaf-environment))
	     (env (make-eval-environment local old-imported)))
	(environment-bound? env 'a)
	(environment-define new-imported 'a #t)
	(eval-environment-set-imported! env new-imported)
	(environment-bound? env 'a)))

    (pass-if "existing binding is replaced"
      (let* ((local (make-leaf-environment))
	     (old-imported (make-leaf-environment))
	     (new-imported (make-leaf-environment))
	     (env (make-eval-environment local old-imported)))
	(environment-define old-imported 'a #f)
	(environment-ref env 'a)
	(environment-define new-imported 'a #t)
	(eval-environment-set-imported! env new-imported)
	(environment-ref env 'a)))

    (pass-if "undefined binding is removed"
      (let* ((local (make-leaf-environment))
	     (old-imported (make-leaf-environment))
	     (new-imported (make-leaf-environment))
	     (env (make-eval-environment local old-imported)))
	(environment-define old-imported 'a #f)
	(environment-ref env 'a)
	(eval-environment-set-imported! env new-imported)
	(not (environment-bound? env 'a))))

    (pass-if "binding in imported remains shadowed"
      (let* ((local (make-leaf-environment))
	     (old-imported (make-leaf-environment))
	     (new-imported (make-leaf-environment))
	     (env (make-eval-environment local old-imported)))
	(environment-define local 'a #t)
	(environment-define old-imported 'a #f)
	(environment-ref env 'a)
	(environment-define new-imported 'a #t)
	(eval-environment-set-imported! env new-imported)
	(environment-ref env 'a)))

    (pass-if "binding in imported gets shadowed"
      (let* ((local (make-leaf-environment))
	     (old-imported (make-leaf-environment))
	     (new-imported (make-leaf-environment))
	     (env (make-eval-environment local old-imported)))
	(environment-define local 'a #t)
	(environment-ref env 'a)
	(environment-define new-imported 'a #f)
	(eval-environment-set-imported! env new-imported)
	(environment-ref env 'a))))

  (with-test-prefix "undefine"

    (pass-if "undefine an already undefined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-undefine env 'a)
	#t))

    (pass-if "undefine removes a binding from local"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define local 'a #t)
	(environment-undefine env 'a)
	(not (environment-bound? local 'a))))

    (pass-if "undefine does not influence imported"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define imported 'a #t)
	(environment-undefine env 'a)
	(environment-bound? imported 'a)))

    (pass-if "undefine an imported symbol does not undefine it"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define imported 'a #t)
	(environment-undefine env 'a)
	(environment-bound? env 'a)))

    (pass-if "undefine unshadows an imported symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define imported 'a #t)
	(environment-define local 'a #f)
	(environment-undefine env 'a)
	(environment-ref env 'a))))

  (with-test-prefix "fold"

    (pass-if "empty environment"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(eq? 'success (environment-fold env folder 'success))))

    (pass-if "one symbol in local"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define local 'a #t)
	(equal? '((a . #t)) (environment-fold env folder '()))))

    (pass-if "one symbol in imported"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define imported 'a #t)
	(equal? '((a . #t)) (environment-fold env folder '()))))

    (pass-if "shadowed symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define local 'a #t)
	(environment-define imported 'a #f)
	(equal? '((a . #t)) (environment-fold env folder '()))))

    (pass-if "one symbol each"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define local 'a #t)
	(environment-define imported 'b #f)
	(let ((folded (environment-fold env folder '())))
	  (or (equal? folded '((a . #t) (b . #f)))
	      (equal? folded '((b . #f) (a . #t))))))))

  (with-test-prefix "observe"

    (pass-if "observe an environment"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-observe env (make-observer-func))
	#t))

    (pass-if "observe an environment twice"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (observer-1 (environment-observe env (make-observer-func)))
	     (observer-2 (environment-observe env (make-observer-func))))
	(not (eq? observer-1 observer-2))))

    (pass-if "definition of an undefined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func)))
	(environment-observe env func)
	(environment-define env 'a 1)
	(eqv? (func) 1)))

    (pass-if "definition of an already defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-define env 'a 1)
	  (eqv? (func) 1))))

    (pass-if "set!ing of a defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-set! env 'a 1)
	  (eqv? (func) 0))))

    (pass-if "undefining a defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe env func)
	  (environment-undefine env 'a)
	  (eqv? (func) 1))))

    (pass-if "undefining an already undefined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func)))
	(environment-observe env func)
	(environment-undefine env 'a)
	(eqv? (func) 0)))

    (pass-if "unobserve an active observer"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func))
	     (observer (environment-observe env func)))
	(environment-unobserve observer)
	(environment-define env 'a 1)
	(eqv? (func) 0)))

    (pass-if "unobserve an inactive observer"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func))
	     (observer (environment-observe env func)))
	(environment-unobserve observer)
	(environment-unobserve observer)
	#t)))

  (with-test-prefix "observe-weak"

    (pass-if "observe an environment"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-observe-weak env (make-observer-func))
	#t))

    (pass-if "observe an environment twice"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (observer-1 (environment-observe-weak env (make-observer-func)))
	     (observer-2 (environment-observe-weak env (make-observer-func))))
	(not (eq? observer-1 observer-2))))

    (pass-if "definition of an undefined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(environment-define env 'a 1)
	(eqv? (func) 1)))

    (pass-if "definition of an already defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-define env 'a 1)
	  (eqv? (func) 1))))

    (pass-if "set!ing of a defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-set! env 'a 1)
	  (eqv? (func) 0))))

    (pass-if "undefining a defined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(environment-define env 'a 1)
	(let* ((func (make-observer-func)))
	  (environment-observe-weak env func)
	  (environment-undefine env 'a)
	  (eqv? (func) 1))))

    (pass-if "undefining an already undefined symbol"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(environment-undefine env 'a)
	(eqv? (func) 0)))

    (pass-if "unobserve an active observer"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func))
	     (observer (environment-observe-weak env func)))
	(environment-unobserve observer)
	(environment-define env 'a 1)
	(eqv? (func) 0)))

    (pass-if "unobserve an inactive observer"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func))
	     (observer (environment-observe-weak env func)))
	(environment-unobserve observer)
	(environment-unobserve observer)
	#t))

    (pass-if "weak observer gets collected"
      (gc)
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func (make-observer-func)))
	(environment-observe-weak env func)
	(gc)
	(environment-define env 'a 1)
	(if (not (eqv? (func) 0))
	    (throw 'unresolved) ; note: conservative scanning
	    #t))))

  (with-test-prefix "erroneous observers"

    (pass-if "update continues after error"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported))
	     (func-1 (make-erroneous-observer-func))
	     (func-2 (make-erroneous-observer-func)))
	(environment-observe env func-1)
	(environment-observe env func-2)
	(catch #t
	  (lambda ()
	    (environment-define env 'a 1)
	    #f)
	  (lambda args
	    (and (eq? (func-1) 1)
		 (eq? (func-2) 1))))))))

;;;
;;; leaf-environment based import-environments
;;;

(with-test-prefix "leaf-environment based import-environments"

  (with-test-prefix "import-environment?"

    (pass-if "documented?"
      (documented? import-environment?))

    (pass-if "non-environment-object"
      (not (import-environment? #f)))

    (pass-if "leaf-environment-object"
      (not (import-environment? (make-leaf-environment))))

    (pass-if "eval-environment-object"
      (let* ((local (make-leaf-environment))
	     (imported (make-leaf-environment))
	     (env (make-eval-environment local imported)))
	(not (import-environment? (make-leaf-environment))))))

  (with-test-prefix "make-import-environment"

    (pass-if "documented?"
      (documented? make-import-environment))))