module/srfi/srfi-64/testing.scm

   1 ;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
   2 ;; Added "full" support for Chicken, Gauche, Guile and SISC.
   3 ;;   Alex Shinn, Copyright (c) 2005.
   4 ;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
   5 ;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
   6 ;;
   7 ;; Permission is hereby granted, free of charge, to any person
   8 ;; obtaining a copy of this software and associated documentation
   9 ;; files (the "Software"), to deal in the Software without
  10 ;; restriction, including without limitation the rights to use, copy,
  11 ;; modify, merge, publish, distribute, sublicense, and/or sell copies
  12 ;; of the Software, and to permit persons to whom the Software is
  13 ;; furnished to do so, subject to the following conditions:
  14 ;;
  15 ;; The above copyright notice and this permission notice shall be
  16 ;; included in all copies or substantial portions of the Software.
  17 ;;
  18 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
  22 ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
  23 ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  24 ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  25 ;; SOFTWARE.
  26
  27 (cond-expand
  28  (chicken
  29   (require-extension syntax-case))
  30  (guile-2
  31   (use-modules (srfi srfi-9)
  32                ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
  33                ;; with either Guile's native exceptions or R6RS exceptions.
  34                ;;(srfi srfi-34) (srfi srfi-35)
  35                (srfi srfi-39)))
  36  (guile
  37   (use-modules (ice-9 syncase) (srfi srfi-9)
  38                ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
  39                (srfi srfi-39)))
  40  (sisc
  41   (require-extension (srfi 9 34 35 39)))
  42  (kawa
  43   (module-compile-options warn-undefined-variable: #t
  44                           warn-invoke-unknown-method: #t)
  45   (provide 'srfi-64)
  46   (provide 'testing)
  47   (require 'srfi-34)
  48   (require 'srfi-35))
  49  (else ()
  50   ))
  51
  52 (cond-expand
  53  (kawa
  54   (define-syntax %test-export
  55     (syntax-rules ()
  56       ((%test-export test-begin . other-names)
  57        (module-export %test-begin . other-names)))))
  58  (else
  59   (define-syntax %test-export
  60     (syntax-rules ()
  61       ((%test-export . names) (if #f #f))))))
  62
  63 ;; List of exported names
  64 (%test-export
  65  test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
  66  test-end test-assert test-eqv test-eq test-equal
  67  test-approximate test-assert test-error test-apply test-with-runner
  68  test-match-nth test-match-all test-match-any test-match-name
  69  test-skip test-expect-fail test-read-eval-string
  70  test-runner-group-path test-group test-group-with-cleanup
  71  test-result-ref test-result-set! test-result-clear test-result-remove
  72  test-result-kind test-passed?
  73  test-log-to-file
  74  ; Misc test-runner functions
  75  test-runner? test-runner-reset test-runner-null
  76  test-runner-simple test-runner-current test-runner-factory test-runner-get
  77  test-runner-create test-runner-test-name
  78  ;; test-runner field setter and getter functions - see %test-record-define:
  79  test-runner-pass-count test-runner-pass-count!
  80  test-runner-fail-count test-runner-fail-count!
  81  test-runner-xpass-count test-runner-xpass-count!
  82  test-runner-xfail-count test-runner-xfail-count!
  83  test-runner-skip-count test-runner-skip-count!
  84  test-runner-group-stack test-runner-group-stack!
  85  test-runner-on-test-begin test-runner-on-test-begin!
  86  test-runner-on-test-end test-runner-on-test-end!
  87  test-runner-on-group-begin test-runner-on-group-begin!
  88  test-runner-on-group-end test-runner-on-group-end!
  89  test-runner-on-final test-runner-on-final!
  90  test-runner-on-bad-count test-runner-on-bad-count!
  91  test-runner-on-bad-end-name test-runner-on-bad-end-name!
  92  test-result-alist test-result-alist!
  93  test-runner-aux-value test-runner-aux-value!
  94  ;; default/simple call-back functions, used in default test-runner,
  95  ;; but can be called to construct more complex ones.
  96  test-on-group-begin-simple test-on-group-end-simple
  97  test-on-bad-count-simple test-on-bad-end-name-simple
  98  test-on-final-simple test-on-test-end-simple
  99  test-on-final-simple)
 100
 101 (cond-expand
 102  (srfi-9
 103   (define-syntax %test-record-define
 104     (syntax-rules ()
 105       ((%test-record-define alloc runner? (name index setter getter) ...)
 106        (define-record-type test-runner
 107          (alloc)
 108          runner?
 109          (name setter getter) ...)))))
 110  (else
 111   (define %test-runner-cookie (list "test-runner"))
 112   (define-syntax %test-record-define
 113     (syntax-rules ()
 114       ((%test-record-define alloc runner? (name index getter setter) ...)
 115        (begin
 116          (define (runner? obj)
 117            (and (vector? obj)
 118                 (> (vector-length obj) 1)
 119                 (eq (vector-ref obj 0) %test-runner-cookie)))
 120          (define (alloc)
 121            (let ((runner (make-vector 23)))
 122              (vector-set! runner 0 %test-runner-cookie)
 123              runner))
 124          (begin
 125            (define (getter runner)
 126              (vector-ref runner index)) ...)
 127          (begin
 128            (define (setter runner value)
 129              (vector-set! runner index value)) ...)))))))
 130
 131 (%test-record-define
 132  %test-runner-alloc test-runner?
 133  ;; Cumulate count of all tests that have passed and were expected to.
 134  (pass-count 1 test-runner-pass-count test-runner-pass-count!)
 135  (fail-count 2 test-runner-fail-count test-runner-fail-count!)
 136  (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
 137  (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
 138  (skip-count 5 test-runner-skip-count test-runner-skip-count!)
 139  (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
 140  (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
 141  ;; Normally #t, except when in a test-apply.
 142  (run-list 8 %test-runner-run-list %test-runner-run-list!)
 143  (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
 144  (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
 145  (group-stack 11 test-runner-group-stack test-runner-group-stack!)
 146  (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
 147  (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
 148  ;; Call-back when entering a group. Takes (runner suite-name count).
 149  (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
 150  ;; Call-back when leaving a group.
 151  (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
 152  ;; Call-back when leaving the outermost group.
 153  (on-final 16 test-runner-on-final test-runner-on-final!)
 154  ;; Call-back when expected number of tests was wrong.
 155  (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
 156  ;; Call-back when name in test=end doesn't match test-begin.
 157  (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
 158  ;; Cumulate count of all tests that have been done.
 159  (total-count 19 %test-runner-total-count %test-runner-total-count!)
 160  ;; Stack (list) of (count-at-start . expected-count):
 161  (count-list 20 %test-runner-count-list %test-runner-count-list!)
 162  (result-alist 21 test-result-alist test-result-alist!)
 163  ;; Field can be used by test-runner for any purpose.
 164  ;; test-runner-simple uses it for a log file.
 165  (aux-value 22 test-runner-aux-value test-runner-aux-value!)
 166 )
 167
 168 (define (test-runner-reset runner)
 169   (test-result-alist! runner '())
 170   (test-runner-pass-count! runner 0)
 171   (test-runner-fail-count! runner 0)
 172   (test-runner-xpass-count! runner 0)
 173   (test-runner-xfail-count! runner 0)
 174   (test-runner-skip-count! runner 0)
 175   (%test-runner-total-count! runner 0)
 176   (%test-runner-count-list! runner '())
 177   (%test-runner-run-list! runner #t)
 178   (%test-runner-skip-list! runner '())
 179   (%test-runner-fail-list! runner '())
 180   (%test-runner-skip-save! runner '())
 181   (%test-runner-fail-save! runner '())
 182   (test-runner-group-stack! runner '()))
 183
 184 (define (test-runner-group-path runner)
 185   (reverse (test-runner-group-stack runner)))
 186
 187 (define (%test-null-callback runner) #f)
 188
 189 (define (test-runner-null)
 190   (let ((runner (%test-runner-alloc)))
 191     (test-runner-reset runner)
 192     (test-runner-on-group-begin! runner (lambda (runner name count) #f))
 193     (test-runner-on-group-end! runner %test-null-callback)
 194     (test-runner-on-final! runner %test-null-callback)
 195     (test-runner-on-test-begin! runner %test-null-callback)
 196     (test-runner-on-test-end! runner %test-null-callback)
 197     (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
 198     (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
 199     runner))
 200
 201 ;; Not part of the specification.  FIXME
 202 ;; Controls whether a log file is generated.
 203 (define test-log-to-file #t)
 204
 205 (define (test-runner-simple)
 206   (let ((runner (%test-runner-alloc)))
 207     (test-runner-reset runner)
 208     (test-runner-on-group-begin! runner test-on-group-begin-simple)
 209     (test-runner-on-group-end! runner test-on-group-end-simple)
 210     (test-runner-on-final! runner test-on-final-simple)
 211     (test-runner-on-test-begin! runner test-on-test-begin-simple)
 212     (test-runner-on-test-end! runner test-on-test-end-simple)
 213     (test-runner-on-bad-count! runner test-on-bad-count-simple)
 214     (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
 215     runner))
 216
 217 (cond-expand
 218  (srfi-39
 219   (define test-runner-current (make-parameter #f))
 220   (define test-runner-factory (make-parameter test-runner-simple)))
 221  (else
 222   (define %test-runner-current #f)
 223   (define-syntax test-runner-current
 224     (syntax-rules ()
 225       ((test-runner-current)
 226        %test-runner-current)
 227       ((test-runner-current runner)
 228        (set! %test-runner-current runner))))
 229   (define %test-runner-factory test-runner-simple)
 230   (define-syntax test-runner-factory
 231     (syntax-rules ()
 232       ((test-runner-factory)
 233        %test-runner-factory)
 234       ((test-runner-factory runner)
 235        (set! %test-runner-factory runner))))))
 236
 237 ;; A safer wrapper to test-runner-current.
 238 (define (test-runner-get)
 239   (let ((r (test-runner-current)))
 240     (if (not r)
 241         (cond-expand
 242          (srfi-23 (error "test-runner not initialized - test-begin missing?"))
 243          (else #t)))
 244     r))
 245
 246 (define (%test-specifier-matches spec runner)
 247   (spec runner))
 248
 249 (define (test-runner-create)
 250   ((test-runner-factory)))
 251
 252 (define (%test-any-specifier-matches list runner)
 253   (let ((result #f))
 254     (let loop ((l list))
 255       (cond ((null? l) result)
 256             (else
 257              (if (%test-specifier-matches (car l) runner)
 258                  (set! result #t))
 259              (loop (cdr l)))))))
 260
 261 ;; Returns #f, #t, or 'xfail.
 262 (define (%test-should-execute runner)
 263   (let ((run (%test-runner-run-list runner)))
 264     (cond ((or
 265             (not (or (eqv? run #t)
 266                      (%test-any-specifier-matches run runner)))
 267             (%test-any-specifier-matches
 268              (%test-runner-skip-list runner)
 269              runner))
 270             (test-result-set! runner 'result-kind 'skip)
 271             #f)
 272           ((%test-any-specifier-matches
 273             (%test-runner-fail-list runner)
 274             runner)
 275            (test-result-set! runner 'result-kind 'xfail)
 276            'xfail)
 277           (else #t))))
 278
 279 (define (%test-begin suite-name count)
 280   (if (not (test-runner-current))
 281       (test-runner-current (test-runner-create)))
 282   (let ((runner (test-runner-current)))
 283     ((test-runner-on-group-begin runner) runner suite-name count)
 284     (%test-runner-skip-save! runner
 285                                (cons (%test-runner-skip-list runner)
 286                                      (%test-runner-skip-save runner)))
 287     (%test-runner-fail-save! runner
 288                                (cons (%test-runner-fail-list runner)
 289                                      (%test-runner-fail-save runner)))
 290     (%test-runner-count-list! runner
 291                              (cons (cons (%test-runner-total-count runner)
 292                                          count)
 293                                    (%test-runner-count-list runner)))
 294     (test-runner-group-stack! runner (cons suite-name
 295                                         (test-runner-group-stack runner)))))
 296 (cond-expand
 297  (kawa
 298   ;; Kawa has test-begin built in, implemented as:
 299   ;; (begin
 300   ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
 301   ;;   (%test-begin suite-name [count]))
 302   ;; This puts test-begin but only test-begin in the default environment.,
 303   ;; which makes normal test suites loadable without non-portable commands.
 304   )
 305  (else
 306   (define-syntax test-begin
 307     (syntax-rules ()
 308       ((test-begin suite-name)
 309        (%test-begin suite-name #f))
 310       ((test-begin suite-name count)
 311        (%test-begin suite-name count))))))
 312
 313 (define (test-on-group-begin-simple runner suite-name count)
 314   (if (null? (test-runner-group-stack runner))
 315       (begin
 316         (display "%%%% Starting test ")
 317         (display suite-name)
 318         (if test-log-to-file
 319             (let* ((log-file-name
 320                     (if (string? test-log-to-file) test-log-to-file
 321                         (string-append suite-name ".log")))
 322                    (log-file
 323                     (cond-expand (mzscheme
 324                                   (open-output-file log-file-name 'truncate/replace))
 325                                  (else (open-output-file log-file-name)))))
 326               (display "%%%% Starting test " log-file)
 327               (display suite-name log-file)
 328               (newline log-file)
 329               (test-runner-aux-value! runner log-file)
 330               (display "  (Writing full log to \"")
 331               (display log-file-name)
 332               (display "\")")))
 333         (newline)))
 334   (let ((log (test-runner-aux-value runner)))
 335     (if (output-port? log)
 336         (begin
 337           (display "Group begin: " log)
 338           (display suite-name log)
 339           (newline log))))
 340   #f)
 341
 342 (define (test-on-group-end-simple runner)
 343   (let ((log (test-runner-aux-value runner)))
 344     (if (output-port? log)
 345         (begin
 346           (display "Group end: " log)
 347           (display (car (test-runner-group-stack runner)) log)
 348           (newline log))))
 349   #f)
 350
 351 (define (%test-on-bad-count-write runner count expected-count port)
 352   (display "*** Total number of tests was " port)
 353   (display count port)
 354   (display " but should be " port)
 355   (display expected-count port)
 356   (display ". ***" port)
 357   (newline port)
 358   (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
 359   (newline port))
 360
 361 (define (test-on-bad-count-simple runner count expected-count)
 362   (%test-on-bad-count-write runner count expected-count (current-output-port))
 363   (let ((log (test-runner-aux-value runner)))
 364     (if (output-port? log)
 365         (%test-on-bad-count-write runner count expected-count log))))
 366
 367 (define (test-on-bad-end-name-simple runner begin-name end-name)
 368   (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
 369                             " does not match test-begin " end-name)))
 370     (cond-expand
 371      (srfi-23 (error msg))
 372      (else (display msg) (newline)))))
 373
 374
 375 (define (%test-final-report1 value label port)
 376   (if (> value 0)
 377       (begin
 378         (display label port)
 379         (display value port)
 380         (newline port))))
 381
 382 (define (%test-final-report-simple runner port)
 383   (%test-final-report1 (test-runner-pass-count runner)
 384                       "# of expected passes      " port)
 385   (%test-final-report1 (test-runner-xfail-count runner)
 386                       "# of expected failures    " port)
 387   (%test-final-report1 (test-runner-xpass-count runner)
 388                       "# of unexpected successes " port)
 389   (%test-final-report1 (test-runner-fail-count runner)
 390                       "# of unexpected failures  " port)
 391   (%test-final-report1 (test-runner-skip-count runner)
 392                       "# of skipped tests        " port))
 393
 394 (define (test-on-final-simple runner)
 395   (%test-final-report-simple runner (current-output-port))
 396   (let ((log (test-runner-aux-value runner)))
 397     (if (output-port? log)
 398         (%test-final-report-simple runner log))))
 399
 400 (define (%test-format-line runner)
 401    (let* ((line-info (test-result-alist runner))
 402           (source-file (assq 'source-file line-info))
 403           (source-line (assq 'source-line line-info))
 404           (file (if source-file (cdr source-file) "")))
 405      (if source-line
 406          (string-append file ":"
 407                         (number->string (cdr source-line)) ": ")
 408          "")))
 409
 410 (define (%test-end suite-name line-info)
 411   (let* ((r (test-runner-get))
 412          (groups (test-runner-group-stack r))
 413          (line (%test-format-line r)))
 414     (test-result-alist! r line-info)
 415     (if (null? groups)
 416         (let ((msg (string-append line "test-end not in a group")))
 417           (cond-expand
 418            (srfi-23 (error msg))
 419            (else (display msg) (newline)))))
 420     (if (and suite-name (not (equal? suite-name (car groups))))
 421         ((test-runner-on-bad-end-name r) r suite-name (car groups)))
 422     (let* ((count-list (%test-runner-count-list r))
 423            (expected-count (cdar count-list))
 424            (saved-count (caar count-list))
 425            (group-count (- (%test-runner-total-count r) saved-count)))
 426       (if (and expected-count
 427                (not (= expected-count group-count)))
 428           ((test-runner-on-bad-count r) r group-count expected-count))
 429       ((test-runner-on-group-end r) r)
 430       (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
 431       (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
 432       (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
 433       (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
 434       (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
 435       (%test-runner-count-list! r (cdr count-list))
 436       (if (null? (test-runner-group-stack r))
 437           ((test-runner-on-final r) r)))))
 438
 439 (define-syntax test-group
 440   (syntax-rules ()
 441     ((test-group suite-name . body)
 442      (let ((r (test-runner-current)))
 443        ;; Ideally should also set line-number, if available.
 444        (test-result-alist! r (list (cons 'test-name suite-name)))
 445        (if (%test-should-execute r)
 446            (dynamic-wind
 447                (lambda () (test-begin suite-name))
 448                (lambda () . body)
 449                (lambda () (test-end  suite-name))))))))
 450
 451 (define-syntax test-group-with-cleanup
 452   (syntax-rules ()
 453     ((test-group-with-cleanup suite-name form cleanup-form)
 454      (test-group suite-name
 455                     (dynamic-wind
 456                         (lambda () #f)
 457                         (lambda () form)
 458                         (lambda () cleanup-form))))
 459     ((test-group-with-cleanup suite-name cleanup-form)
 460      (test-group-with-cleanup suite-name #f cleanup-form))
 461     ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
 462      (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
 463
 464 (define (test-on-test-begin-simple runner)
 465  (let ((log (test-runner-aux-value runner)))
 466     (if (output-port? log)
 467         (let* ((results (test-result-alist runner))
 468                (source-file (assq 'source-file results))
 469                (source-line (assq 'source-line results))
 470                (source-form (assq 'source-form results))
 471                (test-name (assq 'test-name results)))
 472           (display "Test begin:" log)
 473           (newline log)
 474           (if test-name (%test-write-result1 test-name log))
 475           (if source-file (%test-write-result1 source-file log))
 476           (if source-line (%test-write-result1 source-line log))
 477           (if source-form (%test-write-result1 source-form log))))))
 478
 479 (define-syntax test-result-ref
 480   (syntax-rules ()
 481     ((test-result-ref runner pname)
 482      (test-result-ref runner pname #f))
 483     ((test-result-ref runner pname default)
 484      (let ((p (assq pname (test-result-alist runner))))
 485        (if p (cdr p) default)))))
 486
 487 (define (test-on-test-end-simple runner)
 488   (let ((log (test-runner-aux-value runner))
 489         (kind (test-result-ref runner 'result-kind)))
 490     (if (memq kind '(fail xpass))
 491         (let* ((results (test-result-alist runner))
 492                (source-file (assq 'source-file results))
 493                (source-line (assq 'source-line results))
 494                (test-name (assq 'test-name results)))
 495           (if (or source-file source-line)
 496               (begin
 497                 (if source-file (display (cdr source-file)))
 498                 (display ":")
 499                 (if source-line (display (cdr source-line)))
 500                 (display ": ")))
 501           (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
 502           (if test-name
 503               (begin
 504                 (display " ")
 505                 (display (cdr test-name))))
 506           (newline)))
 507     (if (output-port? log)
 508         (begin
 509           (display "Test end:" log)
 510           (newline log)
 511           (let loop ((list (test-result-alist runner)))
 512             (if (pair? list)
 513                 (let ((pair (car list)))
 514                   ;; Write out properties not written out by on-test-begin.
 515                   (if (not (memq (car pair)
 516                                  '(test-name source-file source-line source-form)))
 517                       (%test-write-result1 pair log))
 518                   (loop (cdr list)))))))))
 519
 520 (define (%test-write-result1 pair port)
 521   (display "  " port)
 522   (display (car pair) port)
 523   (display ": " port)
 524   (write (cdr pair) port)
 525   (newline port))
 526
 527 (define (test-result-set! runner pname value)
 528   (let* ((alist (test-result-alist runner))
 529          (p (assq pname alist)))
 530     (if p
 531         (set-cdr! p value)
 532         (test-result-alist! runner (cons (cons pname value) alist)))))
 533
 534 (define (test-result-clear runner)
 535   (test-result-alist! runner '()))
 536
 537 (define (test-result-remove runner pname)
 538   (let* ((alist (test-result-alist runner))
 539          (p (assq pname alist)))
 540     (if p
 541         (test-result-alist! runner
 542                                    (let loop ((r alist))
 543                                      (if (eq? r p) (cdr r)
 544                                          (cons (car r) (loop (cdr r)))))))))
 545
 546 (define (test-result-kind . rest)
 547   (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
 548     (test-result-ref runner 'result-kind)))
 549
 550 (define (test-passed? . rest)
 551   (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
 552     (memq (test-result-ref runner 'result-kind) '(pass xpass))))
 553
 554 (define (%test-report-result)
 555   (let* ((r (test-runner-get))
 556          (result-kind (test-result-kind r)))
 557     (case result-kind
 558       ((pass)
 559        (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
 560       ((fail)
 561        (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
 562       ((xpass)
 563        (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
 564       ((xfail)
 565        (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
 566       (else
 567        (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
 568     (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
 569     ((test-runner-on-test-end r) r)))
 570
 571 (cond-expand
 572  (guile
 573   (define-syntax %test-evaluate-with-catch
 574     (syntax-rules ()
 575       ((%test-evaluate-with-catch test-expression)
 576        (catch #t
 577          (lambda () test-expression)
 578          (lambda (key . args)
 579            (test-result-set! (test-runner-current) 'actual-error
 580                              (cons key args))
 581            #f))))))
 582  (kawa
 583   (define-syntax %test-evaluate-with-catch
 584     (syntax-rules ()
 585       ((%test-evaluate-with-catch test-expression)
 586        (try-catch test-expression
 587                   (ex <java.lang.Throwable>
 588                       (test-result-set! (test-runner-current) 'actual-error ex)
 589                       #f))))))
 590  (srfi-34
 591   (define-syntax %test-evaluate-with-catch
 592     (syntax-rules ()
 593       ((%test-evaluate-with-catch test-expression)
 594        (guard (err (else #f)) test-expression)))))
 595  (chicken
 596   (define-syntax %test-evaluate-with-catch
 597     (syntax-rules ()
 598       ((%test-evaluate-with-catch test-expression)
 599        (condition-case test-expression (ex () #f))))))
 600  (else
 601   (define-syntax %test-evaluate-with-catch
 602     (syntax-rules ()
 603       ((%test-evaluate-with-catch test-expression)
 604        test-expression)))))
 605
 606 (cond-expand
 607  ((or kawa mzscheme)
 608   (cond-expand
 609    (mzscheme
 610     (define-for-syntax (%test-syntax-file form)
 611       (let ((source (syntax-source form)))
 612         (cond ((string? source) file)
 613                                 ((path? source) (path->string source))
 614                                 (else #f)))))
 615    (kawa
 616     (define (%test-syntax-file form)
 617       (syntax-source form))))
 618   (define (%test-source-line2 form)
 619     (let* ((line (syntax-line form))
 620            (file (%test-syntax-file form))
 621            (line-pair (if line (list (cons 'source-line line)) '())))
 622       (cons (cons 'source-form (syntax-object->datum form))
 623             (if file (cons (cons 'source-file file) line-pair) line-pair)))))
 624  (guile-2
 625   (define (%test-source-line2 form)
 626     (let* ((src-props (syntax-source form))
 627            (file (and src-props (assq-ref src-props 'filename)))
 628            (line (and src-props (assq-ref src-props 'line)))
 629            (file-alist (if file
 630                            `((source-file . ,file))
 631                            '()))
 632            (line-alist (if line
 633                            `((source-line . ,(+ line 1)))
 634                            '())))
 635       (datum->syntax (syntax here)
 636                      `((source-form . ,(syntax->datum form))
 637                        ,@file-alist
 638                        ,@line-alist)))))
 639  (else
 640   (define (%test-source-line2 form)
 641     '())))
 642
 643 (define (%test-on-test-begin r)
 644   (%test-should-execute r)
 645   ((test-runner-on-test-begin r) r)
 646   (not (eq? 'skip (test-result-ref r 'result-kind))))
 647
 648 (define (%test-on-test-end r result)
 649     (test-result-set! r 'result-kind
 650                       (if (eq? (test-result-ref r 'result-kind) 'xfail)
 651                           (if result 'xpass 'xfail)
 652                           (if result 'pass 'fail))))
 653
 654 (define (test-runner-test-name runner)
 655   (test-result-ref runner 'test-name ""))
 656
 657 (define-syntax %test-comp2body
 658   (syntax-rules ()
 659                 ((%test-comp2body r comp expected expr)
 660                  (let ()
 661                    (if (%test-on-test-begin r)
 662                        (let ((exp expected))
 663                          (test-result-set! r 'expected-value exp)
 664                          (let ((res (%test-evaluate-with-catch expr)))
 665                            (test-result-set! r 'actual-value res)
 666                            (%test-on-test-end r (comp exp res)))))
 667                    (%test-report-result)))))
 668
 669 (define (%test-approximate= error)
 670   (lambda (value expected)
 671     (let ((rval (real-part value))
 672           (ival (imag-part value))
 673           (rexp (real-part expected))
 674           (iexp (imag-part expected)))
 675       (and (>= rval (- rexp error))
 676            (>= ival (- iexp error))
 677            (<= rval (+ rexp error))
 678            (<= ival (+ iexp error))))))
 679
 680 (define-syntax %test-comp1body
 681   (syntax-rules ()
 682     ((%test-comp1body r expr)
 683      (let ()
 684        (if (%test-on-test-begin r)
 685            (let ()
 686              (let ((res (%test-evaluate-with-catch expr)))
 687                (test-result-set! r 'actual-value res)
 688                (%test-on-test-end r res))))
 689        (%test-report-result)))))
 690
 691 (cond-expand
 692  ((or kawa mzscheme guile-2)
 693   ;; Should be made to work for any Scheme with syntax-case
 694   ;; However, I haven't gotten the quoting working.  FIXME.
 695   (define-syntax test-end
 696     (lambda (x)
 697       (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 698         (((mac suite-name) line)
 699          (syntax
 700           (%test-end suite-name line)))
 701         (((mac) line)
 702          (syntax
 703           (%test-end #f line))))))
 704   (define-syntax test-assert
 705     (lambda (x)
 706       (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 707         (((mac tname expr) line)
 708          (syntax
 709           (let* ((r (test-runner-get))
 710                  (name tname))
 711             (test-result-alist! r (cons (cons 'test-name tname) line))
 712             (%test-comp1body r expr))))
 713         (((mac expr) line)
 714          (syntax
 715           (let* ((r (test-runner-get)))
 716             (test-result-alist! r line)
 717             (%test-comp1body r expr)))))))
 718   (define (%test-comp2 comp x)
 719     (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
 720       (((mac tname expected expr) line comp)
 721        (syntax
 722         (let* ((r (test-runner-get))
 723                (name tname))
 724           (test-result-alist! r (cons (cons 'test-name tname) line))
 725           (%test-comp2body r comp expected expr))))
 726       (((mac expected expr) line comp)
 727        (syntax
 728         (let* ((r (test-runner-get)))
 729           (test-result-alist! r line)
 730           (%test-comp2body r comp expected expr))))))
 731   (define-syntax test-eqv
 732     (lambda (x) (%test-comp2 (syntax eqv?) x)))
 733   (define-syntax test-eq
 734     (lambda (x) (%test-comp2 (syntax eq?) x)))
 735   (define-syntax test-equal
 736     (lambda (x) (%test-comp2 (syntax equal?) x)))
 737   (define-syntax test-approximate ;; FIXME - needed for non-Kawa
 738     (lambda (x)
 739       (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 740       (((mac tname expected expr error) line)
 741        (syntax
 742         (let* ((r (test-runner-get))
 743                (name tname))
 744           (test-result-alist! r (cons (cons 'test-name tname) line))
 745           (%test-comp2body r (%test-approximate= error) expected expr))))
 746       (((mac expected expr error) line)
 747        (syntax
 748         (let* ((r (test-runner-get)))
 749           (test-result-alist! r line)
 750           (%test-comp2body r (%test-approximate= error) expected expr))))))))
 751  (else
 752   (define-syntax test-end
 753     (syntax-rules ()
 754       ((test-end)
 755        (%test-end #f '()))
 756       ((test-end suite-name)
 757        (%test-end suite-name '()))))
 758   (define-syntax test-assert
 759     (syntax-rules ()
 760       ((test-assert tname test-expression)
 761        (let* ((r (test-runner-get))
 762               (name tname))
 763          (test-result-alist! r '((test-name . tname)))
 764          (%test-comp1body r test-expression)))
 765       ((test-assert test-expression)
 766        (let* ((r (test-runner-get)))
 767          (test-result-alist! r '())
 768          (%test-comp1body r test-expression)))))
 769   (define-syntax %test-comp2
 770     (syntax-rules ()
 771       ((%test-comp2 comp tname expected expr)
 772        (let* ((r (test-runner-get))
 773               (name tname))
 774          (test-result-alist! r (list (cons 'test-name tname)))
 775          (%test-comp2body r comp expected expr)))
 776       ((%test-comp2 comp expected expr)
 777        (let* ((r (test-runner-get)))
 778          (test-result-alist! r '())
 779          (%test-comp2body r comp expected expr)))))
 780   (define-syntax test-equal
 781     (syntax-rules ()
 782       ((test-equal . rest)
 783        (%test-comp2 equal? . rest))))
 784   (define-syntax test-eqv
 785     (syntax-rules ()
 786       ((test-eqv . rest)
 787        (%test-comp2 eqv? . rest))))
 788   (define-syntax test-eq
 789     (syntax-rules ()
 790       ((test-eq . rest)
 791        (%test-comp2 eq? . rest))))
 792   (define-syntax test-approximate
 793     (syntax-rules ()
 794       ((test-approximate tname expected expr error)
 795        (%test-comp2 (%test-approximate= error) tname expected expr))
 796       ((test-approximate expected expr error)
 797        (%test-comp2 (%test-approximate= error) expected expr))))))
 798
 799 (cond-expand
 800  (guile
 801   (define-syntax %test-error
 802     (syntax-rules ()
 803       ((%test-error r etype expr)
 804        (cond ((%test-on-test-begin r)
 805               (let ((et etype))
 806                 (test-result-set! r 'expected-error et)
 807                 (%test-on-test-end r
 808                                    (catch #t
 809                                      (lambda ()
 810                                        (test-result-set! r 'actual-value expr)
 811                                        #f)
 812                                      (lambda (key . args)
 813                                        ;; TODO: decide how to specify expected
 814                                        ;; error types for Guile.
 815                                        (test-result-set! r 'actual-error
 816                                                          (cons key args))
 817                                        #t)))
 818                 (%test-report-result))))))))
 819  (mzscheme
 820   (define-syntax %test-error
 821     (syntax-rules ()
 822       ((%test-error r etype expr)
 823        (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
 824                                          (let ()
 825                                            (test-result-set! r 'actual-value expr)
 826                                            #f)))))))
 827  (chicken
 828   (define-syntax %test-error
 829     (syntax-rules ()
 830       ((%test-error r etype expr)
 831         (%test-comp1body r (condition-case expr (ex () #t)))))))
 832  (kawa
 833   (define-syntax %test-error
 834     (syntax-rules ()
 835       ((%test-error r #t expr)
 836        (cond ((%test-on-test-begin r)
 837               (test-result-set! r 'expected-error #t)
 838               (%test-on-test-end r
 839                                  (try-catch
 840                                   (let ()
 841                                     (test-result-set! r 'actual-value expr)
 842                                     #f)
 843                                   (ex <java.lang.Throwable>
 844                                       (test-result-set! r 'actual-error ex)
 845                                       #t)))
 846               (%test-report-result))))
 847       ((%test-error r etype expr)
 848        (if (%test-on-test-begin r)
 849            (let ((et etype))
 850              (test-result-set! r 'expected-error et)
 851              (%test-on-test-end r
 852                                 (try-catch
 853                                  (let ()
 854                                    (test-result-set! r 'actual-value expr)
 855                                    #f)
 856                                  (ex <java.lang.Throwable>
 857                                      (test-result-set! r 'actual-error ex)
 858                                      (cond ((and (instance? et <gnu.bytecode.ClassType>)
 859                                                  (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
 860                                             (instance? ex et))
 861                                            (else #t)))))
 862              (%test-report-result)))))))
 863  ((and srfi-34 srfi-35)
 864   (define-syntax %test-error
 865     (syntax-rules ()
 866       ((%test-error r etype expr)
 867        (%test-comp1body r (guard (ex ((condition-type? etype)
 868                    (and (condition? ex) (condition-has-type? ex etype)))
 869                   ((procedure? etype)
 870                    (etype ex))
 871                   ((equal? etype #t)
 872                    #t)
 873                   (else #t))
 874               expr #f))))))
 875  (srfi-34
 876   (define-syntax %test-error
 877     (syntax-rules ()
 878       ((%test-error r etype expr)
 879        (%test-comp1body r (guard (ex (else #t)) expr #f))))))
 880  (else
 881   (define-syntax %test-error
 882     (syntax-rules ()
 883       ((%test-error r etype expr)
 884        (begin
 885          ((test-runner-on-test-begin r) r)
 886          (test-result-set! r 'result-kind 'skip)
 887          (%test-report-result)))))))
 888
 889 (cond-expand
 890  ((or kawa mzscheme guile-2)
 891
 892   (define-syntax test-error
 893     (lambda (x)
 894       (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
 895         (((mac tname etype expr) line)
 896          (syntax
 897           (let* ((r (test-runner-get))
 898                  (name tname))
 899             (test-result-alist! r (cons (cons 'test-name tname) line))
 900             (%test-error r etype expr))))
 901         (((mac etype expr) line)
 902          (syntax
 903           (let* ((r (test-runner-get)))
 904             (test-result-alist! r line)
 905             (%test-error r etype expr))))
 906         (((mac expr) line)
 907          (syntax
 908           (let* ((r (test-runner-get)))
 909             (test-result-alist! r line)
 910             (%test-error r #t expr))))))))
 911  (else
 912   (define-syntax test-error
 913     (syntax-rules ()
 914       ((test-error name etype expr)
 915        (let ((r (test-runner-get)))
 916          (test-result-alist! r `((test-name . ,name)))
 917          (%test-error r etype expr)))
 918       ((test-error etype expr)
 919        (let ((r (test-runner-get)))
 920          (test-result-alist! r '())
 921          (%test-error r etype expr)))
 922       ((test-error expr)
 923        (let ((r (test-runner-get)))
 924          (test-result-alist! r '())
 925          (%test-error r #t expr)))))))
 926
 927 (define (test-apply first . rest)
 928   (if (test-runner? first)
 929       (test-with-runner first (apply test-apply rest))
 930       (let ((r (test-runner-current)))
 931         (if r
 932             (let ((run-list (%test-runner-run-list r)))
 933               (cond ((null? rest)
 934                      (%test-runner-run-list! r (reverse run-list))
 935                      (first)) ;; actually apply procedure thunk
 936                     (else
 937                      (%test-runner-run-list!
 938                       r
 939                       (if (eq? run-list #t) (list first) (cons first run-list)))
 940                      (apply test-apply rest)
 941                      (%test-runner-run-list! r run-list))))
 942             (let ((r (test-runner-create)))
 943               (test-with-runner r (apply test-apply first rest))
 944               ((test-runner-on-final r) r))))))
 945
 946 (define-syntax test-with-runner
 947   (syntax-rules ()
 948     ((test-with-runner runner form ...)
 949      (let ((saved-runner (test-runner-current)))
 950        (dynamic-wind
 951            (lambda () (test-runner-current runner))
 952            (lambda () form ...)
 953            (lambda () (test-runner-current saved-runner)))))))
 954
 955 ;;; Predicates
 956
 957 (define (%test-match-nth n count)
 958   (let ((i 0))
 959     (lambda (runner)
 960       (set! i (+ i 1))
 961       (and (>= i n) (< i (+ n count))))))
 962
 963 (define-syntax test-match-nth
 964   (syntax-rules ()
 965     ((test-match-nth n)
 966      (test-match-nth n 1))
 967     ((test-match-nth n count)
 968      (%test-match-nth n count))))
 969
 970 (define (%test-match-all . pred-list)
 971   (lambda (runner)
 972     (let ((result #t))
 973       (let loop ((l pred-list))
 974         (if (null? l)
 975             result
 976             (begin
 977               (if (not ((car l) runner))
 978                   (set! result #f))
 979               (loop (cdr l))))))))
 980
 981 (define-syntax test-match-all
 982   (syntax-rules ()
 983     ((test-match-all pred ...)
 984      (%test-match-all (%test-as-specifier pred) ...))))
 985
 986 (define (%test-match-any . pred-list)
 987   (lambda (runner)
 988     (let ((result #f))
 989       (let loop ((l pred-list))
 990         (if (null? l)
 991             result
 992             (begin
 993               (if ((car l) runner)
 994                   (set! result #t))
 995               (loop (cdr l))))))))
 996
 997 (define-syntax test-match-any
 998   (syntax-rules ()
 999     ((test-match-any pred ...)
1000      (%test-match-any (%test-as-specifier pred) ...))))
1001
1002 ;; Coerce to a predicate function:
1003 (define (%test-as-specifier specifier)
1004   (cond ((procedure? specifier) specifier)
1005         ((integer? specifier) (test-match-nth 1 specifier))
1006         ((string? specifier) (test-match-name specifier))
1007         (else
1008          (error "not a valid test specifier"))))
1009
1010 (define-syntax test-skip
1011   (syntax-rules ()
1012     ((test-skip pred ...)
1013      (let ((runner (test-runner-get)))
1014        (%test-runner-skip-list! runner
1015                                   (cons (test-match-all (%test-as-specifier pred)  ...)
1016                                         (%test-runner-skip-list runner)))))))
1017
1018 (define-syntax test-expect-fail
1019   (syntax-rules ()
1020     ((test-expect-fail pred ...)
1021      (let ((runner (test-runner-get)))
1022        (%test-runner-fail-list! runner
1023                                   (cons (test-match-all (%test-as-specifier pred)  ...)
1024                                         (%test-runner-fail-list runner)))))))
1025
1026 (define (test-match-name name)
1027   (lambda (runner)
1028     (equal? name (test-runner-test-name runner))))
1029
1030 (define (test-read-eval-string string)
1031   (let* ((port (open-input-string string))
1032          (form (read port)))
1033     (if (eof-object? (read-char port))
1034         (cond-expand
1035          (guile (eval form (current-module)))
1036          (else (eval form)))
1037         (cond-expand
1038          (srfi-23 (error "(not at eof)"))
1039          (else "error")))))
1040