test-suite/lib.scm

   1 ;;;; test-suite/lib.scm --- generic support for testing
   2 ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This program is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 3, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This program is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;;; GNU Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this software; see the file COPYING.LESSER.
  16 ;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
  17 ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (test-suite lib)
  20   :use-module (ice-9 stack-catch)
  21   :use-module (ice-9 regex)
  22   :autoload   (srfi srfi-1)  (append-map)
  23   :export (
  24
  25  ;; Exceptions which are commonly being tested for.
  26  exception:syntax-pattern-unmatched
  27  exception:bad-variable
  28  exception:missing-expression
  29  exception:out-of-range exception:unbound-var
  30  exception:used-before-defined
  31  exception:wrong-num-args exception:wrong-type-arg
  32  exception:numerical-overflow
  33  exception:struct-set!-denied
  34  exception:system-error
  35  exception:encoding-error
  36  exception:miscellaneous-error
  37  exception:string-contains-nul
  38  exception:read-error
  39  exception:null-pointer-error
  40  exception:vm-error
  41
  42  ;; Reporting passes and failures.
  43  run-test
  44  pass-if expect-fail
  45  pass-if-exception expect-fail-exception
  46
  47  ;; Naming groups of tests in a regular fashion.
  48  with-test-prefix with-test-prefix* current-test-prefix
  49  format-test-name
  50
  51  ;; Using the debugging evaluator.
  52  with-debugging-evaluator with-debugging-evaluator*
  53
  54  ;; Using a given locale
  55  with-locale with-locale* with-latin1-locale with-latin1-locale*
  56
  57  ;; Reporting results in various ways.
  58  register-reporter unregister-reporter reporter-registered?
  59  make-count-reporter print-counts
  60  make-log-reporter
  61  full-reporter
  62  user-reporter))
  63
  64
  65 ;;;; If you're using Emacs's Scheme mode:
  66 ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
  67
  68 \f
  69 ;;;; CORE FUNCTIONS
  70 ;;;;
  71 ;;;; The function (run-test name expected-result thunk) is the heart of the
  72 ;;;; testing environment.  The first parameter NAME is a unique name for the
  73 ;;;; test to be executed (for an explanation of this parameter see below under
  74 ;;;; TEST NAMES).  The second parameter EXPECTED-RESULT is a boolean value
  75 ;;;; that indicates whether the corresponding test is expected to pass.  If
  76 ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
  77 ;;;; #f the test is expected to fail.  Finally, THUNK is the function that
  78 ;;;; actually performs the test.  For example:
  79 ;;;;
  80 ;;;;    (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
  81 ;;;;
  82 ;;;; To report success, THUNK should either return #t or throw 'pass.  To
  83 ;;;; report failure, THUNK should either return #f or throw 'fail.  If THUNK
  84 ;;;; returns a non boolean value or throws 'unresolved, this indicates that
  85 ;;;; the test did not perform as expected.  For example the property that was
  86 ;;;; to be tested could not be tested because something else went wrong.
  87 ;;;; THUNK may also throw 'untested to indicate that the test was deliberately
  88 ;;;; not performed, for example because the test case is not complete yet.
  89 ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
  90 ;;;; requires some feature that is not available in the configured testing
  91 ;;;; environment.  All other exceptions thrown by THUNK are considered as
  92 ;;;; errors.
  93 ;;;;
  94 ;;;;
  95 ;;;; Convenience macros for tests expected to pass or fail
  96 ;;;;
  97 ;;;; * (pass-if name body) is a short form for
  98 ;;;;   (run-test name #t (lambda () body))
  99 ;;;; * (expect-fail name body) is a short form for
 100 ;;;;   (run-test name #f (lambda () body))
 101 ;;;;
 102 ;;;; For example:
 103 ;;;;
 104 ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
 105 ;;;;
 106 ;;;;
 107 ;;;; Convenience macros to test for exceptions
 108 ;;;;
 109 ;;;; The following macros take exception parameters which are pairs
 110 ;;;; (type . message), where type is a symbol that denotes an exception type
 111 ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
 112 ;;;; regular expression that describes the error message for the exception
 113 ;;;; like "Argument .* out of range".
 114 ;;;;
 115 ;;;; * (pass-if-exception name exception body) will pass if the execution of
 116 ;;;;   body causes the given exception to be thrown.  If no exception is
 117 ;;;;   thrown, the test fails.  If some other exception is thrown, is is an
 118 ;;;;   error.
 119 ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
 120 ;;;;   the execution of body causes the given exception to be thrown.  If no
 121 ;;;;   exception is thrown, the test fails expectedly.  If some other
 122 ;;;;   exception is thrown, it is an error.
 123
 124 \f
 125 ;;;; TEST NAMES
 126 ;;;;
 127 ;;;; Every test in the test suite has a unique name, to help
 128 ;;;; developers find tests that are failing (or unexpectedly passing),
 129 ;;;; and to help gather statistics.
 130 ;;;;
 131 ;;;; A test name is a list of printable objects.  For example:
 132 ;;;; ("ports.scm" "file" "read and write back list of strings")
 133 ;;;; ("ports.scm" "pipe" "read")
 134 ;;;;
 135 ;;;; Test names may contain arbitrary objects, but they always have
 136 ;;;; the following properties:
 137 ;;;; - Test names can be compared with EQUAL?.
 138 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
 139 ;;;;   and READ procedures; doing so preserves their identity.
 140 ;;;;
 141 ;;;; For example:
 142 ;;;;
 143 ;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
 144 ;;;;
 145 ;;;; In that case, the test name is the list ("simple addition").
 146 ;;;;
 147 ;;;; In the case of simple tests the expression that is tested would often
 148 ;;;; suffice as a test name by itself.  Therefore, the convenience macros
 149 ;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
 150 ;;;; a test name in such cases.
 151 ;;;;
 152 ;;;; * (pass-if expression) is a short form for
 153 ;;;;   (run-test 'expression #t (lambda () expression))
 154 ;;;; * (expect-fail expression) is a short form for
 155 ;;;;   (run-test 'expression #f (lambda () expression))
 156 ;;;;
 157 ;;;; For example:
 158 ;;;;
 159 ;;;;    (pass-if (= 2 (+ 1 1)))
 160 ;;;;
 161 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
 162 ;;;; a prefix for the names of all tests whose results are reported
 163 ;;;; within their dynamic scope.  For example:
 164 ;;;;
 165 ;;;; (begin
 166 ;;;;   (with-test-prefix "basic arithmetic"
 167 ;;;;     (pass-if "addition" (= (+ 2 2) 4))
 168 ;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
 169 ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
 170 ;;;;
 171 ;;;; In that example, the three test names are:
 172 ;;;;   ("basic arithmetic" "addition"),
 173 ;;;;   ("basic arithmetic" "subtraction"), and
 174 ;;;;   ("multiplication").
 175 ;;;;
 176 ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
 177 ;;;; a new element to the current prefix:
 178 ;;;;
 179 ;;;; (with-test-prefix "arithmetic"
 180 ;;;;   (with-test-prefix "addition"
 181 ;;;;     (pass-if "integer" (= (+ 2 2) 4))
 182 ;;;;     (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
 183 ;;;;   (with-test-prefix "subtraction"
 184 ;;;;     (pass-if "integer" (= (- 2 2) 0))
 185 ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
 186 ;;;;
 187 ;;;; The four test names here are:
 188 ;;;;   ("arithmetic" "addition" "integer")
 189 ;;;;   ("arithmetic" "addition" "complex")
 190 ;;;;   ("arithmetic" "subtraction" "integer")
 191 ;;;;   ("arithmetic" "subtraction" "complex")
 192 ;;;;
 193 ;;;; To print a name for a human reader, we DISPLAY its elements,
 194 ;;;; separated by ": ".  So, the last set of test names would be
 195 ;;;; reported as:
 196 ;;;;
 197 ;;;;   arithmetic: addition: integer
 198 ;;;;   arithmetic: addition: complex
 199 ;;;;   arithmetic: subtraction: integer
 200 ;;;;   arithmetic: subtraction: complex
 201 ;;;;
 202 ;;;; The Guile benchmarks use with-test-prefix to include the name of
 203 ;;;; the source file containing the test in the test name, to help
 204 ;;;; developers to find failing tests, and to provide each file with its
 205 ;;;; own namespace.
 206
 207 \f
 208 ;;;; REPORTERS
 209 ;;;;
 210 ;;;; A reporter is a function which we apply to each test outcome.
 211 ;;;; Reporters can log results, print interesting results to the
 212 ;;;; standard output, collect statistics, etc.
 213 ;;;;
 214 ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
 215 ;;;; possibly additional arguments depending on RESULT; its return value
 216 ;;;; is ignored.  RESULT has one of the following forms:
 217 ;;;;
 218 ;;;; pass         - The test named TEST passed.
 219 ;;;;                Additional arguments are ignored.
 220 ;;;; upass        - The test named TEST passed unexpectedly.
 221 ;;;;                Additional arguments are ignored.
 222 ;;;; fail         - The test named TEST failed.
 223 ;;;;                Additional arguments are ignored.
 224 ;;;; xfail        - The test named TEST failed, as expected.
 225 ;;;;                Additional arguments are ignored.
 226 ;;;; unresolved   - The test named TEST did not perform as expected, for
 227 ;;;;                example the property that was to be tested could not be
 228 ;;;;                tested because something else went wrong.
 229 ;;;;                Additional arguments are ignored.
 230 ;;;; untested     - The test named TEST was not actually performed, for
 231 ;;;;                example because the test case is not complete yet.
 232 ;;;;                Additional arguments are ignored.
 233 ;;;; unsupported  - The test named TEST requires some feature that is not
 234 ;;;;                available in the configured testing environment.
 235 ;;;;                Additional arguments are ignored.
 236 ;;;; error        - An error occurred while the test named TEST was
 237 ;;;;                performed.  Since this result means that the system caught
 238 ;;;;                an exception it could not handle, the exception arguments
 239 ;;;;                are passed as additional arguments.
 240 ;;;;
 241 ;;;; This library provides some standard reporters for logging results
 242 ;;;; to a file, reporting interesting results to the user, and
 243 ;;;; collecting totals.
 244 ;;;;
 245 ;;;; You can use the REGISTER-REPORTER function and friends to add
 246 ;;;; whatever reporting functions you like.  If you don't register any
 247 ;;;; reporters, the library uses FULL-REPORTER, which simply writes
 248 ;;;; all results to the standard output.
 249
 250 \f
 251 ;;;; MISCELLANEOUS
 252 ;;;;
 253
 254 ;;; Define some exceptions which are commonly being tested for.
 255 (define exception:syntax-pattern-unmatched
 256   (cons 'syntax-error "source expression failed to match any pattern"))
 257 (define exception:bad-variable
 258   (cons 'syntax-error "Bad variable"))
 259 (define exception:missing-expression
 260   (cons 'misc-error "^missing or extra expression"))
 261 (define exception:out-of-range
 262   (cons 'out-of-range "^.*out of range"))
 263 (define exception:unbound-var
 264   (cons 'unbound-variable "^Unbound variable"))
 265 (define exception:used-before-defined
 266   (cons 'unbound-variable "^Variable used before given a value"))
 267 (define exception:wrong-num-args
 268   (cons 'wrong-number-of-args "^Wrong number of arguments"))
 269 (define exception:wrong-type-arg
 270   (cons 'wrong-type-arg "^Wrong type"))
 271 (define exception:numerical-overflow
 272   (cons 'numerical-overflow "^Numerical overflow"))
 273 (define exception:struct-set!-denied
 274   (cons 'misc-error "^set! denied for field"))
 275 (define exception:system-error
 276   (cons 'system-error ".*"))
 277 (define exception:encoding-error
 278   (cons 'encoding-error "(cannot convert to output locale|input locale conversion error)"))
 279 (define exception:miscellaneous-error
 280   (cons 'misc-error "^.*"))
 281 (define exception:read-error
 282   (cons 'read-error "^.*$"))
 283 (define exception:null-pointer-error
 284   (cons 'null-pointer-error "^.*$"))
 285 (define exception:vm-error
 286   (cons 'vm-error "^.*$"))
 287
 288 ;; as per throw in scm_to_locale_stringn()
 289 (define exception:string-contains-nul
 290   (cons 'misc-error "^string contains #\\\\nul character"))
 291
 292
 293 ;;; Display all parameters to the default output port, followed by a newline.
 294 (define (display-line . objs)
 295   (for-each display objs)
 296   (newline))
 297
 298 ;;; Display all parameters to the given output port, followed by a newline.
 299 (define (display-line-port port . objs)
 300   (for-each (lambda (obj) (display obj port)) objs)
 301   (newline port))
 302
 303 \f
 304 ;;;; CORE FUNCTIONS
 305 ;;;;
 306
 307 ;;; The central testing routine.
 308 ;;; The idea is taken from Greg, the GNUstep regression test environment.
 309 (define run-test #f)
 310 (let ((test-running #f))
 311   (define (local-run-test name expect-pass thunk)
 312     (if test-running
 313         (error "Nested calls to run-test are not permitted.")
 314         (let ((test-name (full-name name)))
 315           (set! test-running #t)
 316           (catch #t
 317             (lambda ()
 318               (let ((result (thunk)))
 319                 (if (eq? result #t) (throw 'pass))
 320                 (if (eq? result #f) (throw 'fail))
 321                 (throw 'unresolved)))
 322             (lambda (key . args)
 323               (case key
 324                 ((pass)
 325                  (report (if expect-pass 'pass 'upass) test-name))
 326                 ((fail)
 327                  (report (if expect-pass 'fail 'xfail) test-name))
 328                 ((unresolved untested unsupported)
 329                  (report key test-name))
 330                 ((quit)
 331                  (report 'unresolved test-name)
 332                  (quit))
 333                 (else
 334                  (report 'error test-name (cons key args))))))
 335           (set! test-running #f))))
 336   (set! run-test local-run-test))
 337
 338 ;;; A short form for tests that are expected to pass, taken from Greg.
 339 (define-syntax pass-if
 340   (syntax-rules ()
 341     ((_ name)
 342      ;; presume this is a simple test, i.e. (pass-if (even? 2))
 343      ;; where the body should also be the name.
 344      (run-test 'name #t (lambda () name)))
 345     ((_ name rest ...)
 346      (run-test name #t (lambda () rest ...)))))
 347
 348 ;;; A short form for tests that are expected to fail, taken from Greg.
 349 (define-syntax expect-fail
 350   (syntax-rules ()
 351     ((_ name)
 352      ;; presume this is a simple test, i.e. (expect-fail (even? 2))
 353      ;; where the body should also be the name.
 354      (run-test 'name #f (lambda () name)))
 355     ((_ name rest ...)
 356      (run-test name #f (lambda () rest ...)))))
 357
 358 ;;; A helper function to implement the macros that test for exceptions.
 359 (define (run-test-exception name exception expect-pass thunk)
 360   (run-test name expect-pass
 361     (lambda ()
 362       (stack-catch (car exception)
 363         (lambda () (thunk) #f)
 364         (lambda (key proc message . rest)
 365           (cond
 366            ;; handle explicit key
 367            ((string-match (cdr exception) message)
 368             #t)
 369            ;; handle `(error ...)' which uses `misc-error' for key and doesn't
 370            ;; yet format the message and args (we have to do it here).
 371            ((and (eq? 'misc-error (car exception))
 372                  (list? rest)
 373                  (string-match (cdr exception)
 374                                (apply simple-format #f message (car rest))))
 375             #t)
 376            ;; handle syntax errors which use `syntax-error' for key and don't
 377            ;; yet format the message and args (we have to do it here).
 378            ((and (eq? 'syntax-error (car exception))
 379                  (list? rest)
 380                  (string-match (cdr exception)
 381                                (apply simple-format #f message (car rest))))
 382             #t)
 383            ;; unhandled; throw again
 384            (else
 385             (apply throw key proc message rest))))))))
 386
 387 ;;; A short form for tests that expect a certain exception to be thrown.
 388 (define-syntax pass-if-exception
 389   (syntax-rules ()
 390     ((_ name exception body rest ...)
 391      (run-test-exception name exception #t (lambda () body rest ...)))))
 392
 393 ;;; A short form for tests expected to fail to throw a certain exception.
 394 (define-syntax expect-fail-exception
 395   (syntax-rules ()
 396     ((_ name exception body rest ...)
 397      (run-test-exception name exception #f (lambda () body rest ...)))))
 398
 399 \f
 400 ;;;; TEST NAMES
 401 ;;;;
 402
 403 ;;;; Turn a test name into a nice human-readable string.
 404 (define (format-test-name name)
 405   ;; Choose a Unicode-capable encoding so that the string port can contain any
 406   ;; valid Unicode character.
 407   (with-fluids ((%default-port-encoding "UTF-8"))
 408     (call-with-output-string
 409      (lambda (port)
 410        (let loop ((name name)
 411                   (separator ""))
 412          (if (pair? name)
 413              (begin
 414                (display separator port)
 415                (display (car name) port)
 416                (loop (cdr name) ": "))))))))
 417
 418 ;;;; For a given test-name, deliver the full name including all prefixes.
 419 (define (full-name name)
 420   (append (current-test-prefix) (list name)))
 421
 422 ;;; A fluid containing the current test prefix, as a list.
 423 (define prefix-fluid (make-fluid))
 424 (fluid-set! prefix-fluid '())
 425 (define (current-test-prefix)
 426   (fluid-ref prefix-fluid))
 427
 428 ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
 429 ;;; The name prefix is only changed within the dynamic scope of the
 430 ;;; call to with-test-prefix*.  Return the value returned by THUNK.
 431 (define (with-test-prefix* prefix thunk)
 432   (with-fluids ((prefix-fluid
 433                  (append (fluid-ref prefix-fluid) (list prefix))))
 434     (thunk)))
 435
 436 ;;; (with-test-prefix PREFIX BODY ...)
 437 ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
 438 ;;; The name prefix is only changed within the dynamic scope of the
 439 ;;; with-test-prefix expression.  Return the value returned by the last
 440 ;;; BODY expression.
 441 (defmacro with-test-prefix (prefix . body)
 442   `(with-test-prefix* ,prefix (lambda () ,@body)))
 443
 444 ;;; Call THUNK using the debugging evaluator.
 445 (define (with-debugging-evaluator* thunk)
 446   (let ((dopts #f))
 447     (dynamic-wind
 448         (lambda ()
 449           (set! dopts (debug-options)))
 450         thunk
 451         (lambda ()
 452           (debug-options dopts)))))
 453
 454 ;;; Evaluate BODY... using the debugging evaluator.
 455 (define-macro (with-debugging-evaluator . body)
 456   `(with-debugging-evaluator* (lambda () ,@body)))
 457
 458 ;;; Call THUNK with a given locale
 459 (define (with-locale* nloc thunk)
 460   (let ((loc #f))
 461     (dynamic-wind
 462         (lambda ()
 463           (if (defined? 'setlocale)
 464               (begin
 465                 (set! loc (false-if-exception (setlocale LC_ALL)))
 466                 (if (or (not loc)
 467                         (not (false-if-exception (setlocale LC_ALL nloc))))
 468                     (throw 'unresolved)))
 469               (throw 'unresolved)))
 470         thunk
 471         (lambda ()
 472           (if (and (defined? 'setlocale) loc)
 473               (setlocale LC_ALL loc))))))
 474
 475 ;;; Evaluate BODY... using the given locale.
 476 (define-syntax with-locale
 477   (syntax-rules ()
 478     ((_ loc body ...)
 479      (with-locale* loc (lambda () body ...)))))
 480
 481 ;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
 482 ;;; (if any).
 483 (define (with-latin1-locale* thunk)
 484   (define %locales
 485     (append-map (lambda (name)
 486                   (list (string-append name ".ISO-8859-1")
 487                         (string-append name ".iso88591")
 488                         (string-append name ".ISO8859-1")))
 489                 '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
 490                   "fr_FR" "pt_PT" "nl_NL" "sv_SE")))
 491
 492   (let loop ((locales %locales))
 493     (if (null? locales)
 494         (throw 'unresolved)
 495         (catch 'unresolved
 496           (lambda ()
 497             (with-locale* (car locales) thunk))
 498           (lambda (key . args)
 499             (loop (cdr locales)))))))
 500
 501 ;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
 502 ;;; was found.
 503 (define-syntax with-latin1-locale
 504   (syntax-rules ()
 505     ((_ body ...)
 506      (with-latin1-locale* (lambda () body ...)))))
 507
 508 \f
 509 ;;;; REPORTERS
 510 ;;;;
 511
 512 ;;; The global list of reporters.
 513 (define reporters '())
 514
 515 ;;; The default reporter, to be used only if no others exist.
 516 (define default-reporter #f)
 517
 518 ;;; Add the procedure REPORTER to the current set of reporter functions.
 519 ;;; Signal an error if that reporter procedure object is already registered.
 520 (define (register-reporter reporter)
 521   (if (memq reporter reporters)
 522       (error "register-reporter: reporter already registered: " reporter))
 523   (set! reporters (cons reporter reporters)))
 524
 525 ;;; Remove the procedure REPORTER from the current set of reporter
 526 ;;; functions.  Signal an error if REPORTER is not currently registered.
 527 (define (unregister-reporter reporter)
 528   (if (memq reporter reporters)
 529       (set! reporters (delq! reporter reporters))
 530       (error "unregister-reporter: reporter not registered: " reporter)))
 531
 532 ;;; Return true iff REPORTER is in the current set of reporter functions.
 533 (define (reporter-registered? reporter)
 534   (if (memq reporter reporters) #t #f))
 535
 536 ;;; Send RESULT to all currently registered reporter functions.
 537 (define (report . args)
 538   (if (pair? reporters)
 539       (for-each (lambda (reporter) (apply reporter args))
 540                 reporters)
 541       (apply default-reporter args)))
 542
 543 \f
 544 ;;;; Some useful standard reporters:
 545 ;;;; Count reporters count the occurrence of each test result type.
 546 ;;;; Log reporters write all test results to a given log file.
 547 ;;;; Full reporters write all test results to the standard output.
 548 ;;;; User reporters write interesting test results to the standard output.
 549
 550 ;;; The complete list of possible test results.
 551 (define result-tags
 552   '((pass        "PASS"        "passes:                 ")
 553     (fail        "FAIL"        "failures:               ")
 554     (upass       "UPASS"       "unexpected passes:      ")
 555     (xfail       "XFAIL"       "expected failures:      ")
 556     (unresolved  "UNRESOLVED"  "unresolved test cases:  ")
 557     (untested    "UNTESTED"    "untested test cases:    ")
 558     (unsupported "UNSUPPORTED" "unsupported test cases: ")
 559     (error       "ERROR"       "errors:                 ")))
 560
 561 ;;; The list of important test results.
 562 (define important-result-tags
 563   '(fail upass unresolved error))
 564
 565 ;;; Display a single test result in formatted form to the given port
 566 (define (print-result port result name . args)
 567   (let* ((tag (assq result result-tags))
 568          (label (if tag (cadr tag) #f)))
 569     (if label
 570         (begin
 571           (display label port)
 572           (display ": " port)
 573           (display (format-test-name name) port)
 574           (if (pair? args)
 575               (begin
 576                 (display " - arguments: " port)
 577                 (write args port)))
 578           (newline port))
 579         (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
 580                result))))
 581
 582 ;;; Return a list of the form (COUNTER RESULTS), where:
 583 ;;; - COUNTER is a reporter procedure, and
 584 ;;; - RESULTS is a procedure taking no arguments which returns the
 585 ;;;   results seen so far by COUNTER.  The return value is an alist
 586 ;;;   mapping outcome symbols (`pass', `fail', etc.) onto counts.
 587 (define (make-count-reporter)
 588   (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
 589     (list
 590      (lambda (result name . args)
 591        (let ((pair (assq result counts)))
 592          (if pair
 593              (set-cdr! pair (+ 1 (cdr pair)))
 594              (error "count-reporter: unexpected test result: "
 595                     (cons result (cons name args))))))
 596      (lambda ()
 597        (append counts '())))))
 598
 599 ;;; Print a count reporter's results nicely.  Pass this function the value
 600 ;;; returned by a count reporter's RESULTS procedure.
 601 (define (print-counts results . port?)
 602   (let ((port (if (pair? port?)
 603                   (car port?)
 604                   (current-output-port))))
 605     (newline port)
 606     (display-line-port port "Totals for this test run:")
 607     (for-each
 608      (lambda (tag)
 609        (let ((result (assq (car tag) results)))
 610          (if result
 611              (display-line-port port (caddr tag) (cdr result))
 612              (display-line-port port
 613                                 "Test suite bug: "
 614                                 "no total available for `" (car tag) "'"))))
 615      result-tags)
 616     (newline port)))
 617
 618 ;;; Return a reporter procedure which prints all results to the file
 619 ;;; FILE, in human-readable form.  FILE may be a filename, or a port.
 620 (define (make-log-reporter file)
 621   (let ((port (if (output-port? file) file
 622                   (open-output-file file))))
 623     (lambda args
 624       (apply print-result port args)
 625       (force-output port))))
 626
 627 ;;; A reporter that reports all results to the user.
 628 (define (full-reporter . args)
 629   (apply print-result (current-output-port) args))
 630
 631 ;;; A reporter procedure which shows interesting results (failures,
 632 ;;; unexpected passes etc.) to the user.
 633 (define (user-reporter result name . args)
 634   (if (memq result important-result-tags)
 635       (apply full-reporter result name args)))
 636
 637 (set! default-reporter full-reporter)