srfi/srfi-64.upstream.scm

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