Import guile's own testing framework

2 files changed, 800 insertions, 0 deletions

diff --git a/gnuradio-core/src/guile/test-suite/guile-test b/gnuradio-core/src/guile/test-suite/guile-test
new file mode 100755
index 000000000..1e1c70a77
--- /dev/null
+++ b/gnuradio-core/src/guile/test-suite/guile-test
@@ -0,0 +1,241 @@
+#!../libguile/guile \
+-e main -s
+!#
+
+;;;; guile-test --- run the Guile test suite
+;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
+;;;;
+;;;; 	Copyright (C) 1999, 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
+
+
+;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
+;;;;
+;;;; Run tests from the Guile test suite.  Report failures and
+;;;; unexpected passes to the standard output, along with a summary of
+;;;; all the results.  Record each reported test outcome in the log
+;;;; file, `guile.log'.  The exit status is #f if any of the tests
+;;;; fail or pass unexpectedly.
+;;;;
+;;;; Normally, guile-test scans the test directory, and executes all
+;;;; files whose names end in `.test'.  (It assumes they contain
+;;;; Scheme code.)  However, you can have it execute specific tests by
+;;;; listing their filenames on the command line.
+;;;;
+;;;; The option `--test-suite' can be given to specify the test
+;;;; directory.  If no such option is given, the test directory is
+;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
+;;;; otherwise a default directory that is hardcoded in this file is
+;;;; used (see "Installation" below).
+;;;;
+;;;; If present, the `--log-file LOG' option tells `guile-test' to put
+;;;; the log output in a file named LOG.
+;;;;
+;;;; If present, the `--debug' option will enable a debugging mode.
+;;;;
+;;;; If present, the `--flag-unresolved' option will cause guile-test
+;;;; to exit with failure status if any tests are UNRESOLVED.
+;;;;
+;;;;
+;;;; Installation:
+;;;;
+;;;; If you change the #! line at the top of this script to point at
+;;;; the Guile interpreter you want to test, you can call this script
+;;;; as an executable instead of having to pass it as a parameter to
+;;;; guile via "guile -e main -s guile-test".  Further, you can edit
+;;;; the definition of default-test-suite to point to the parent
+;;;; directory of the `tests' tree, which makes it unnecessary to set
+;;;; the environment variable `TEST_SUITE_DIR'.
+;;;;
+;;;;
+;;;; Shortcomings:
+;;;;
+;;;; At the moment, due to a simple-minded implementation, test files
+;;;; must live in the test directory, and you must specify their names
+;;;; relative to the top of the test directory.  If you want to send
+;;;; me a patch that fixes this, but still leaves sane test names in
+;;;; the log file, that would be great.  At the moment, all the tests
+;;;; I care about are in the test directory, though.
+;;;;
+;;;; It would be nice if you could specify the Guile interpreter you
+;;;; want to test on the command line.  As it stands, if you want to
+;;;; change which Guile interpreter you're testing, you need to edit
+;;;; the #! line at the top of this file, which is stupid.
+
+(define (main . args)
+  (let ((module (resolve-module '(test-suite guile-test))))
+    (apply (module-ref module 'main) args)))
+
+(define-module (test-suite guile-test)
+  :use-module (test-suite lib)
+  :use-module (ice-9 getopt-long)
+  :use-module (ice-9 and-let-star)
+  :use-module (ice-9 rdelim)
+  :export (main data-file-name test-file-name))
+
+
+;;; User configurable settings:
+(define default-test-suite
+  (string-append (getenv "HOME") "/bogus-path/test-suite"))
+
+
+;;; Variables that will receive their actual values later.
+(define test-suite default-test-suite)
+
+(define tmp-dir #f)
+
+
+;;; General utilities, that probably should be in a library somewhere.
+
+;;; Enable debugging
+(define (enable-debug-mode)
+  (write-line %load-path)
+  (set! %load-verbosely #t)
+  (debug-enable 'backtrace 'debug))
+
+;;; Traverse the directory tree at ROOT, applying F to the name of
+;;; each file in the tree, including ROOT itself.  For a subdirectory
+;;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
+;;; symlinks.
+(define (for-each-file f root)
+
+  ;; A "hard directory" is a path that denotes a directory and is not a
+  ;; symlink.
+  (define (file-is-hard-directory? filename)
+    (eq? (stat:type (lstat filename)) 'directory))
+
+  (let visit ((root root))
+    (let ((should-recur (f root)))
+      (if (and should-recur (file-is-hard-directory? root))
+	  (let ((dir (opendir root)))
+	    (let loop ()
+	      (let ((entry (readdir dir)))
+		(cond
+		 ((eof-object? entry) #f)
+		 ((or (string=? entry ".")
+		      (string=? entry "..")
+                      (string=? entry "CVS")
+                      (string=? entry "RCS"))
+		  (loop))
+		 (else
+		  (visit (string-append root "/" entry))
+		  (loop))))))))))
+
+
+;;; The test driver.
+
+
+;;; Localizing test files and temporary data files.
+
+(define (data-file-name filename)
+  (in-vicinity tmp-dir filename))
+
+(define (test-file-name test)
+  (in-vicinity test-suite test))
+
+;;; Return a list of all the test files in the test tree.
+(define (enumerate-tests test-dir)
+  (let ((root-len (+ 1 (string-length test-dir)))
+	(tests '()))
+    (for-each-file (lambda (file)
+		     (if (has-suffix? file ".test")
+			 (let ((short-name
+				(substring file root-len)))
+			   (set! tests (cons short-name tests))))
+		     #t)
+		   test-dir)
+
+    ;; for-each-file presents the files in whatever order it finds
+    ;; them in the directory.  We sort them here, so they'll always
+    ;; appear in the same order.  This makes it easier to compare test
+    ;; log files mechanically.
+    (sort tests string<?)))
+
+(define (main args)
+  (let ((options (getopt-long args
+			      `((test-suite
+				 (single-char #\t)
+				 (value #t))
+                                (flag-unresolved
+                                 (single-char #\u))
+				(log-file
+				 (single-char #\l)
+				 (value #t))
+				(debug
+				 (single-char #\d))))))
+    (define (opt tag default)
+      (let ((pair (assq tag options)))
+	(if pair (cdr pair) default)))
+
+    (if (opt 'debug #f)
+	(enable-debug-mode))
+
+    (set! test-suite
+	  (or (opt 'test-suite #f)
+	      (getenv "TEST_SUITE_DIR")
+	      default-test-suite))
+
+    ;; directory where temporary files are created.
+    ;; when run from "make check", this must be under the build-dir,
+    ;; not the src-dir.
+    (set! tmp-dir (getcwd))
+
+    (let* ((tests
+	    (let ((foo (opt '() '())))
+	      (if (null? foo)
+		  (enumerate-tests test-suite)
+		  foo)))
+	   (log-file
+	    (opt 'log-file "guile.log")))
+
+      ;; Open the log file.
+      (let ((log-port (open-output-file log-file)))
+
+	;; Register some reporters.
+	(let ((global-pass #t)
+	      (counter (make-count-reporter)))
+	  (register-reporter (car counter))
+	  (register-reporter (make-log-reporter log-port))
+	  (register-reporter user-reporter)
+	  (register-reporter (lambda results
+			       (case (car results)
+                                 ((unresolved)
+                                  (and (opt 'flag-unresolved #f)
+                                       (set! global-pass #f)))
+				 ((fail upass error)
+				  (set! global-pass #f)))))
+
+	  ;; Run the tests.
+	  (for-each (lambda (test)
+                      (display (string-append "Running " test "\n"))
+		      (with-test-prefix test
+			(load (test-file-name test))))
+		    tests)
+
+	  ;; Display the final counts, both to the user and in the log
+	  ;; file.
+	  (let ((counts ((cadr counter))))
+	    (print-counts counts)
+	    (print-counts counts log-port))
+
+	  (close-port log-port)
+	  (quit global-pass))))))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; End:
diff --git a/gnuradio-core/src/guile/test-suite/lib.scm b/gnuradio-core/src/guile/test-suite/lib.scm
new file mode 100644
index 000000000..c4ddf9e7c
--- /dev/null
+++ b/gnuradio-core/src/guile/test-suite/lib.scm
@@ -0,0 +1,559 @@
+;;;; test-suite/lib.scm --- generic support for testing
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 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 lib)
+  :use-module (ice-9 stack-catch)
+  :use-module (ice-9 regex)
+  :export (
+
+ ;; Exceptions which are commonly being tested for.
+ exception:bad-variable
+ exception:missing-expression
+ exception:out-of-range exception:unbound-var
+ exception:used-before-defined
+ exception:wrong-num-args exception:wrong-type-arg
+ exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:system-error
+ exception:miscellaneous-error
+ exception:string-contains-nul
+
+ ;; Reporting passes and failures.
+ run-test
+ pass-if expect-fail
+ pass-if-exception expect-fail-exception
+
+ ;; Naming groups of tests in a regular fashion.
+ with-test-prefix with-test-prefix* current-test-prefix
+ format-test-name
+
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
+
+ ;; Reporting results in various ways.
+ register-reporter unregister-reporter reporter-registered?
+ make-count-reporter print-counts
+ make-log-reporter
+ full-reporter
+ user-reporter))
+
+
+;;;; If you're using Emacs's Scheme mode:
+;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
+
+
+;;;; CORE FUNCTIONS
+;;;;
+;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; testing environment.  The first parameter NAME is a unique name for the
+;;;; test to be executed (for an explanation of this parameter see below under
+;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
+;;;; that indicates whether the corresponding test is expected to pass.  If
+;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
+;;;; #f the test is expected to fail.  Finally, THUNK is the function that
+;;;; actually performs the test.  For example:
+;;;;
+;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;;
+;;;; To report success, THUNK should either return #t or throw 'pass.  To
+;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
+;;;; returns a non boolean value or throws 'unresolved, this indicates that
+;;;; the test did not perform as expected.  For example the property that was
+;;;; to be tested could not be tested because something else went wrong.
+;;;; THUNK may also throw 'untested to indicate that the test was deliberately
+;;;; not performed, for example because the test case is not complete yet.
+;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
+;;;; requires some feature that is not available in the configured testing
+;;;; environment.  All other exceptions thrown by THUNK are considered as
+;;;; errors.
+;;;;
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
+;;;; * (pass-if name body) is a short form for
+;;;;   (run-test name #t (lambda () body))
+;;;; * (expect-fail name body) is a short form for
+;;;;   (run-test name #f (lambda () body))
+;;;;
+;;;; For example:
+;;;;
+;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;;   body causes the given exception to be thrown.  If no exception is
+;;;;   thrown, the test fails.  If some other exception is thrown, is is an
+;;;;   error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;;   the execution of body causes the given exception to be thrown.  If no
+;;;;   exception is thrown, the test fails expectedly.  If some other
+;;;;   exception is thrown, it is an error.
+
+
+;;;; TEST NAMES
+;;;;
+;;;; Every test in the test suite has a unique name, to help
+;;;; developers find tests that are failing (or unexpectedly passing),
+;;;; and to help gather statistics.
+;;;;
+;;;; A test name is a list of printable objects.  For example:
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Test names may contain arbitrary objects, but they always have
+;;;; the following properties:
+;;;; - Test names can be compared with EQUAL?.
+;;;; - Test names can be reliably stored and retrieved with the standard WRITE
+;;;;   and READ procedures; doing so preserves their identity.
+;;;;
+;;;; For example:
+;;;;
+;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
+;;;;
+;;;; In that case, the test name is the list ("simple addition").
+;;;;
+;;;; In the case of simple tests the expression that is tested would often
+;;;; suffice as a test name by itself.  Therefore, the convenience macros
+;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
+;;;; a test name in such cases.
+;;;;
+;;;; * (pass-if expression) is a short form for
+;;;;   (run-test 'expression #t (lambda () expression))
+;;;; * (expect-fail expression) is a short form for
+;;;;   (run-test 'expression #f (lambda () expression))
+;;;;
+;;;; For example:
+;;;;
+;;;;    (pass-if (= 2 (+ 1 1)))
+;;;;
+;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
+;;;; a prefix for the names of all tests whose results are reported
+;;;; within their dynamic scope.  For example:
+;;;;
+;;;; (begin
+;;;;   (with-test-prefix "basic arithmetic"
+;;;;     (pass-if "addition" (= (+ 2 2) 4))
+;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
+;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
+;;;;
+;;;; In that example, the three test names are:
+;;;;   ("basic arithmetic" "addition"),
+;;;;   ("basic arithmetic" "subtraction"), and
+;;;;   ("multiplication").
+;;;;
+;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
+;;;; a new element to the current prefix:
+;;;;
+;;;; (with-test-prefix "arithmetic"
+;;;;   (with-test-prefix "addition"
+;;;;     (pass-if "integer" (= (+ 2 2) 4))
+;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
+;;;;   (with-test-prefix "subtraction"
+;;;;     (pass-if "integer" (= (- 2 2) 0))
+;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
+;;;;
+;;;; The four test names here are:
+;;;;   ("arithmetic" "addition" "integer")
+;;;;   ("arithmetic" "addition" "complex")
+;;;;   ("arithmetic" "subtraction" "integer")
+;;;;   ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by ": ".  So, the last set of test names would be
+;;;; reported as:
+;;;;
+;;;;   arithmetic: addition: integer
+;;;;   arithmetic: addition: complex
+;;;;   arithmetic: subtraction: integer
+;;;;   arithmetic: subtraction: complex
+;;;;
+;;;; The Guile benchmarks use with-test-prefix to include the name of
+;;;; the source file containing the test in the test name, to help
+;;;; developers to find failing tests, and to provide each file with its
+;;;; own namespace.
+
+
+;;;; REPORTERS
+;;;;
+;;;; A reporter is a function which we apply to each test outcome.
+;;;; Reporters can log results, print interesting results to the
+;;;; standard output, collect statistics, etc.
+;;;;
+;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
+;;;; possibly additional arguments depending on RESULT; its return value
+;;;; is ignored.  RESULT has one of the following forms:
+;;;;
+;;;; pass         - The test named TEST passed.
+;;;;                Additional arguments are ignored.
+;;;; upass        - The test named TEST passed unexpectedly.
+;;;;                Additional arguments are ignored.
+;;;; fail         - The test named TEST failed.
+;;;;                Additional arguments are ignored.
+;;;; xfail        - The test named TEST failed, as expected.
+;;;;                Additional arguments are ignored.
+;;;; unresolved   - The test named TEST did not perform as expected, for
+;;;;                example the property that was to be tested could not be
+;;;;                tested because something else went wrong.
+;;;;                Additional arguments are ignored.
+;;;; untested     - The test named TEST was not actually performed, for
+;;;;                example because the test case is not complete yet.
+;;;;                Additional arguments are ignored.
+;;;; unsupported  - The test named TEST requires some feature that is not
+;;;;                available in the configured testing environment.
+;;;;                Additional arguments are ignored.
+;;;; error        - An error occurred while the test named TEST was
+;;;;                performed.  Since this result means that the system caught
+;;;;                an exception it could not handle, the exception arguments
+;;;;                are passed as additional arguments.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, and
+;;;; collecting totals.
+;;;;
+;;;; You can use the REGISTER-REPORTER function and friends to add
+;;;; whatever reporting functions you like.  If you don't register any
+;;;; reporters, the library uses FULL-REPORTER, which simply writes
+;;;; all results to the standard output.
+
+
+;;;; MISCELLANEOUS
+;;;;
+
+;;; Define some exceptions which are commonly being tested for.
+(define exception:bad-variable
+  (cons 'syntax-error "Bad variable"))
+(define exception:missing-expression
+  (cons 'misc-error "^missing or extra expression"))
+(define exception:out-of-range
+  (cons 'out-of-range "^.*out of range"))
+(define exception:unbound-var
+  (cons 'unbound-variable "^Unbound variable"))
+(define exception:used-before-defined
+  (cons 'unbound-variable "^Variable used before given a value"))
+(define exception:wrong-num-args
+  (cons 'wrong-number-of-args "^Wrong number of arguments"))
+(define exception:wrong-type-arg
+  (cons 'wrong-type-arg "^Wrong type"))
+(define exception:numerical-overflow
+  (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+  (cons 'misc-error "^set! denied for field"))
+(define exception:system-error
+  (cons 'system-error ".*"))
+(define exception:miscellaneous-error
+  (cons 'misc-error "^.*"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception:string-contains-nul
+  (cons 'misc-error "^string contains #\\\\nul character"))
+
+
+;;; Display all parameters to the default output port, followed by a newline.
+(define (display-line . objs)
+  (for-each display objs)
+  (newline))
+
+;;; Display all parameters to the given output port, followed by a newline.
+(define (display-line-port port . objs)
+  (for-each (lambda (obj) (display obj port)) objs)
+  (newline port))
+
+
+;;;; CORE FUNCTIONS
+;;;;
+
+;;; The central testing routine.
+;;; The idea is taken from Greg, the GNUstep regression test environment.
+(define run-test #f)
+(let ((test-running #f))
+  (define (local-run-test name expect-pass thunk)
+    (if test-running
+	(error "Nested calls to run-test are not permitted.")
+	(let ((test-name (full-name name)))
+	  (set! test-running #t)
+	  (catch #t
+	    (lambda ()
+	      (let ((result (thunk)))
+		(if (eq? result #t) (throw 'pass))
+		(if (eq? result #f) (throw 'fail))
+		(throw 'unresolved)))
+	    (lambda (key . args)
+	      (case key
+		((pass)
+		 (report (if expect-pass 'pass 'upass) test-name))
+		((fail)
+		 (report (if expect-pass 'fail 'xfail) test-name))
+		((unresolved untested unsupported)
+		 (report key test-name))
+		((quit)
+		 (report 'unresolved test-name)
+		 (quit))
+		(else
+		 (report 'error test-name (cons key args))))))
+	  (set! test-running #f))))
+  (set! run-test local-run-test))
+
+;;; A short form for tests that are expected to pass, taken from Greg.
+(defmacro pass-if (name . rest)
+  (if (and (null? rest) (pair? name))
+      ;; presume this is a simple test, i.e. (pass-if (even? 2))
+      ;; where the body should also be the name.
+      `(run-test ',name #t (lambda () ,name))
+      `(run-test ,name #t (lambda () ,@rest))))
+
+;;; A short form for tests that are expected to fail, taken from Greg.
+(defmacro expect-fail (name . rest)
+  (if (and (null? rest) (pair? name))
+      ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+      ;; where the body should also be the name.
+      `(run-test ',name #f (lambda () ,name))
+      `(run-test ,name #f (lambda () ,@rest))))
+
+;;; A helper function to implement the macros that test for exceptions.
+(define (run-test-exception name exception expect-pass thunk)
+  (run-test name expect-pass
+    (lambda ()
+      (stack-catch (car exception)
+	(lambda () (thunk) #f)
+	(lambda (key proc message . rest)
+	  (cond
+           ;; handle explicit key
+           ((string-match (cdr exception) message)
+            #t)
+           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'misc-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
+           ;; handle syntax errors which use `syntax-error' for key and don't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'syntax-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
+           ;; unhandled; throw again
+           (else
+            (apply throw key proc message rest))))))))
+
+;;; A short form for tests that expect a certain exception to be thrown.
+(defmacro pass-if-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(defmacro expect-fail-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+
+
+;;;; TEST NAMES
+;;;;
+
+;;;; Turn a test name into a nice human-readable string.
+(define (format-test-name name)
+  (call-with-output-string
+   (lambda (port)
+     (let loop ((name name)
+		(separator ""))
+       (if (pair? name)
+	   (begin
+	     (display separator port)
+	     (display (car name) port)
+	     (loop (cdr name) ": ")))))))
+
+;;;; For a given test-name, deliver the full name including all prefixes.
+(define (full-name name)
+  (append (current-test-prefix) (list name)))
+
+;;; A fluid containing the current test prefix, as a list.
+(define prefix-fluid (make-fluid))
+(fluid-set! prefix-fluid '())
+(define (current-test-prefix)
+  (fluid-ref prefix-fluid))
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-test-prefix*.  Return the value returned by THUNK.
+(define (with-test-prefix* prefix thunk)
+  (with-fluids ((prefix-fluid
+		 (append (fluid-ref prefix-fluid) (list prefix))))
+    (thunk)))
+
+;;; (with-test-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-test-prefix expression.  Return the value returned by the last
+;;; BODY expression.
+(defmacro with-test-prefix (prefix . body)
+  `(with-test-prefix* ,prefix (lambda () ,@body)))
+
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+  (let ((dopts #f))
+    (dynamic-wind
+	(lambda ()
+	  (set! dopts (debug-options))
+	  (debug-enable 'debug))
+	thunk
+	(lambda ()
+	  (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+  `(with-debugging-evaluator* (lambda () ,@body)))
+
+
+
+;;;; REPORTERS
+;;;;
+
+;;; The global list of reporters.
+(define reporters '())
+
+;;; The default reporter, to be used only if no others exist.
+(define default-reporter #f)
+
+;;; Add the procedure REPORTER to the current set of reporter functions.
+;;; Signal an error if that reporter procedure object is already registered.
+(define (register-reporter reporter)
+  (if (memq reporter reporters)
+      (error "register-reporter: reporter already registered: " reporter))
+  (set! reporters (cons reporter reporters)))
+
+;;; Remove the procedure REPORTER from the current set of reporter
+;;; functions.  Signal an error if REPORTER is not currently registered.
+(define (unregister-reporter reporter)
+  (if (memq reporter reporters)
+      (set! reporters (delq! reporter reporters))
+      (error "unregister-reporter: reporter not registered: " reporter)))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+  (if (memq reporter reporters) #t #f))
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report . args)
+  (if (pair? reporters)
+      (for-each (lambda (reporter) (apply reporter args))
+		reporters)
+      (apply default-reporter args)))
+
+
+;;;; Some useful standard reporters:
+;;;; Count reporters count the occurrence of each test result type.
+;;;; Log reporters write all test results to a given log file.
+;;;; Full reporters write all test results to the standard output.
+;;;; User reporters write interesting test results to the standard output.
+
+;;; The complete list of possible test results.
+(define result-tags
+  '((pass        "PASS"        "passes:                 ")
+    (fail        "FAIL"        "failures:               ")
+    (upass       "UPASS"       "unexpected passes:      ")
+    (xfail       "XFAIL"       "expected failures:      ")
+    (unresolved  "UNRESOLVED"  "unresolved test cases:  ")
+    (untested    "UNTESTED"    "untested test cases:    ")
+    (unsupported "UNSUPPORTED" "unsupported test cases: ")
+    (error       "ERROR"       "errors:                 ")))
+
+;;; The list of important test results.
+(define important-result-tags
+  '(fail upass unresolved error))
+
+;;; Display a single test result in formatted form to the given port
+(define (print-result port result name . args)
+  (let* ((tag (assq result result-tags))
+	 (label (if tag (cadr tag) #f)))
+    (if label
+	(begin
+	  (display label port)
+	  (display ": " port)
+	  (display (format-test-name name) port)
+	  (if (pair? args)
+	      (begin
+		(display " - arguments: " port)
+		(write args port)))
+	  (newline port))
+	(error "(test-suite lib) FULL-REPORTER: unrecognized result: "
+	       result))))
+
+;;; Return a list of the form (COUNTER RESULTS), where:
+;;; - COUNTER is a reporter procedure, and
+;;; - RESULTS is a procedure taking no arguments which returns the
+;;;   results seen so far by COUNTER.  The return value is an alist
+;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
+(define (make-count-reporter)
+  (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
+    (list
+     (lambda (result name . args)
+       (let ((pair (assq result counts)))
+	 (if pair
+	     (set-cdr! pair (+ 1 (cdr pair)))
+	     (error "count-reporter: unexpected test result: "
+		    (cons result (cons name args))))))
+     (lambda ()
+       (append counts '())))))
+
+;;; Print a count reporter's results nicely.  Pass this function the value
+;;; returned by a count reporter's RESULTS procedure.
+(define (print-counts results . port?)
+  (let ((port (if (pair? port?)
+		  (car port?)
+		  (current-output-port))))
+    (newline port)
+    (display-line-port port "Totals for this test run:")
+    (for-each
+     (lambda (tag)
+       (let ((result (assq (car tag) results)))
+	 (if result
+	     (display-line-port port (caddr tag) (cdr result))
+	     (display-line-port port
+				"Test suite bug: "
+				"no total available for `" (car tag) "'"))))
+     result-tags)
+    (newline port)))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form.  FILE may be a filename, or a port.
+(define (make-log-reporter file)
+  (let ((port (if (output-port? file) file
+		  (open-output-file file))))
+    (lambda args
+      (apply print-result port args)
+      (force-output port))))
+
+;;; A reporter that reports all results to the user.
+(define (full-reporter . args)
+  (apply print-result (current-output-port) args))
+
+;;; A reporter procedure which shows interesting results (failures,
+;;; unexpected passes etc.) to the user.
+(define (user-reporter result name . args)
+  (if (memq result important-result-tags)
+      (apply full-reporter result name args)))
+
+(set! default-reporter full-reporter)