#!../libguile/guile \

-e main -s

!#

;;;; guile-test --- run the Guile test suite

;;;; Jim Blandy <ji[email protected]> --- 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:

;;;; 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)