test-suite/test-suite/lib.scm

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