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