Merge branch 'aws-s3'
[rl3.git] / rl3 / test / unit-tests.sls
blobf357fcfad1c6daacc726fd04a5366cc7adf69cad
1 ;; Port of SRFI-78 to ERR5RS.  See bottom for copyright information.
3 (library
4  (rl3 test unit-tests utils)
5  
6  (export
7   %test-source-line2)
8  
9  (import
10   (for (rnrs base)
11        run))
13  (define (%test-source-line2 form)
14    '())
16  )
19 (library 
20  (rl3 test unit-tests)
22  (export
23   test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
24   test-end test-assert test-eqv? test-eq? test-equal?
25   test-approximate test-error test-apply test-with-runner
26   test-match-nth test-match-all test-match-any test-match-name
27   test-skip test-expect-fail ;; test-read-eval-string
28   test-runner-group-path test-group-with-cleanup
29   test-result-ref test-result-set! test-result-clear test-result-remove
30   test-result-kind test-passed?
31   test-log-to-file
32   ;; Misc test-runner functions
33   test-runner? test-runner-reset test-runner-null
34   test-runner-simple test-runner-current test-runner-factory test-runner-get
35   test-runner-create test-runner-test-name
36   ;; test-runner field setter and getter functions - see %test-record-define:
37   test-runner-pass-count test-runner-pass-count-set!
38   test-runner-fail-count test-runner-fail-count-set!
39   test-runner-xpass-count test-runner-xpass-count-set!
40   test-runner-xfail-count test-runner-xfail-count-set!
41   test-runner-skip-count test-runner-skip-count-set!
42   test-runner-group-stack test-runner-group-stack-set!
43   test-runner-on-test-begin test-runner-on-test-begin-set!
44   test-runner-on-test-end test-runner-on-test-end-set!
45   test-runner-on-group-begin test-runner-on-group-begin-set!
46   test-runner-on-group-end test-runner-on-group-end-set!
47   test-runner-on-final test-runner-on-final-set!
48   test-runner-on-bad-count test-runner-on-bad-count-set!
49   test-runner-on-bad-end-name test-runner-on-bad-end-name-set!
50   test-runner-result-alist test-runner-result-alist-set!
51   test-runner-aux-value test-runner-aux-value-set!
52   ;; default/simple call-back functions, used in default test-runner,
53   ;; but can be called to construct more complex ones.
54   test-on-group-begin-simple test-on-group-end-simple
55   test-on-bad-count-simple test-on-bad-end-name-simple
56   test-on-final-simple test-on-test-end-simple)
58  (import
59   (for (rnrs base)
60        run expand)
61   (for (rnrs exceptions)
62        run expand)
63   (only (rnrs io simple)
64         open-output-file
65         display newline write)
66   (only (rnrs control)
67         unless when)
68   (only (rnrs io ports)
69         current-output-port
70         get-char
71         eof-object? output-port?)
72   (for (rnrs syntax-case)
73        run expand)
74   (for (rl3 test unit-tests utils)
75        run expand)
76   (only (rnrs lists)
77         assq memq)
78   (only (rl3 env parameters)
79         make-parameter)
80   (only (rnrs mutable-pairs)
81         set-cdr!)
82   (err5rs records syntactic))
84  (define-record-type test-runner #t #t
85    (pass-count)  (fail-count)
86    (xpass-count) (xfail-count)
87    (skip-count)  (skip-list)
88    (fail-list)   (run-list)
89    (skip-save)   (fail-save)
90    (group-stack)
91    (on-test-begin) (on-test-end)
92    ;; call-back when entering a group.  Takes (runeer suite-name count)
93    (on-group-begin)
94    ;; call-back when leaving a group
95    (on-group-end)
96    (on-final)
97    (on-bad-count)
98    (on-bad-end-name)
99    (total-count)
100    (count-list)
101    (result-alist)
102    (aux-value))
104  (define test-runner-alloc
105    (lambda ()
106      (make-test-runner 0 0 0 0 0 '() '() '() #t #t #f #f #f #f #f #f #f #f 0 '() '() #f)))
108  (define (test-runner-reset runner)
109    (test-runner-pass-count-set!  runner 0)
110    (test-runner-fail-count-set!  runner 0)
111    (test-runner-xpass-count-set! runner 0)
112    (test-runner-xfail-count-set! runner 0)
113    (test-runner-skip-count-set!  runner 0)
114    (test-runner-total-count-set! runner 0)
115    (test-runner-count-list-set!  runner '())
116    (test-runner-run-list-set!    runner #t)
117    (test-runner-skip-list-set!   runner '())
118    (test-runner-fail-list-set!   runner '())
119    (test-runner-skip-save-set!   runner '())
120    (test-runner-fail-save-set!   runner '())
121    (test-runner-group-stack-set! runner '()))
123  (define (test-runner-group-path runner)
124    (reverse (test-runner-group-stack runner)))
126  (define (%test-null-callback runner) #f)
128  (define test-runner-null
129    (lambda ()
130      (let ((runner (test-runner-alloc)))
131        (test-runner-reset runner)
132        (test-runner-on-group-begin-set! runner (lambda (runner name count) #f))
133        (test-runner-on-group-end-set! runner %test-null-callback)
134        (test-runner-on-final-set! runner %test-null-callback)
135        (test-runner-on-test-begin-set! runner %test-null-callback)
136        (test-runner-on-test-end-set! runner %test-null-callback)
137        (test-runner-on-bad-count-set! runner (lambda (runner count expected) #f))
138        (test-runner-on-bad-end-name-set! runner (lambda (runner begin end) #f))
139        runner)))
141  ;; Not part of the specification.  FIXME
142  ;; Controls whether a log file is generated.
143  (define test-log-to-file #t)
145  (define test-runner-simple
146    (lambda ()
147      (let ((runner (test-runner-alloc)))
148        (test-runner-reset runner)
149        (test-runner-on-group-begin-set! runner test-on-group-begin-simple)
150        (test-runner-on-group-end-set! runner test-on-group-end-simple)
151        (test-runner-on-final-set! runner test-on-final-simple)
152        (test-runner-on-test-begin-set! runner test-on-test-begin-simple)
153        (test-runner-on-test-end-set! runner test-on-test-end-simple)
154        (test-runner-on-bad-count-set! runner test-on-bad-count-simple)
155        (test-runner-on-bad-end-name-set! runner test-on-bad-end-name-simple)
156        runner)))
158  (define test-runner-current
159    (make-parameter 'test-runner-current #f))
161  (define test-runner-factory
162    (make-parameter 'set-runner-simple test-runner-simple))
164  ;; A safer wrapper to test-runner-current.
165  (define test-runner-get
166    (lambda ()
167      (let ((r (test-runner-current)))
168        (unless r
169          (error "test-runner not initialized - test-begin missing?"))
170        r)))
172  (define (%test-specificier-matches spec runner)
173    (spec runner))
175  (define (test-runner-create)
176    ((test-runner-factory)))
178  (define (%test-any-specifier-matches list runner)
179    (let ((result #f))
180      (let loop ((l list))
181        (cond ((null? l) result)
182              (else
183               (if (%test-specificier-matches (car l) runner)
184                   (set! result #t))
185               (loop (cdr l)))))))
187  ;; Returns #f, #t, or 'xfail.
188  (define (%test-should-execute runner)
189    (let ((run (test-runner-run-list runner)))
190      (cond ((or
191              (not (or (eqv? run #t)
192                       (%test-any-specifier-matches run runner)))
193              (%test-any-specifier-matches
194               (test-runner-skip-list runner)
195               runner))
196             (test-result-set! runner 'result-kind 'skip)
197             #f)
198            ((%test-any-specifier-matches
199              (test-runner-fail-list runner)
200              runner)
201             (test-result-set! runner 'result-kind 'xfail)
202             'xfail)
203            (else #t))))
205  (define (%test-begin suite-name count)
206    (if (not (test-runner-current))
207        (test-runner-current (test-runner-create)))
208    (let ((runner (test-runner-current)))
209      ((test-runner-on-group-begin runner) runner suite-name count)
210      (test-runner-skip-save-set! runner
211                                  (cons (test-runner-skip-list runner)
212                                        (test-runner-skip-save runner)))
213      (test-runner-fail-save-set! runner
214                                  (cons (test-runner-fail-list runner)
215                                        (test-runner-fail-save runner)))
216      (test-runner-count-list-set! runner
217                                   (cons (cons (test-runner-total-count runner)
218                                               count)
219                                         (test-runner-count-list runner)))
220      (test-runner-group-stack-set! runner (cons suite-name
221                                                 (test-runner-group-stack runner)))))
222  (define-syntax test-begin
223    (syntax-rules ()
224      ((test-begin suite-name)
225       (%test-begin suite-name #f))
226      ((test-begin suite-name count)
227       (%test-begin suite-name count))))
229  (define (test-on-group-begin-simple runner suite-name count)
230    (if (null? (test-runner-group-stack runner))
231        (begin
232          (display "%%%% Starting test ")
233          (display suite-name)
234          (if test-log-to-file
235              (let* ((log-file-name
236                      (if (string? test-log-to-file) test-log-to-file
237                          (string-append suite-name ".log")))
238                     (log-file (open-output-file log-file-name)))
239                (display "%%%% Starting test " log-file)
240                (display suite-name log-file)
241                (newline log-file)
242                (test-runner-aux-value-set! runner log-file)
243                (display "  (Writing full log to \"")
244                (display log-file-name)
245                (display "\")")))
246          (newline)))
247    (let ((log (test-runner-aux-value runner)))
248      (if (output-port? log)
249          (begin
250            (display "Group begin: " log)
251            (display suite-name log)
252            (newline log))))
253    #f)
255  (define (test-on-group-end-simple runner)
256    (let ((log (test-runner-aux-value runner)))
257      (if (output-port? log)
258          (begin
259            (display "Group end: " log)
260            (display (car (test-runner-group-stack runner)) log)
261            (newline log))))
262    #f)
264  (define (%test-on-bad-count-write runner count expected-count port)
265    (display "*** Total number of tests was " port)
266    (display count port)
267    (display " but should be " port)
268    (display expected-count port)
269    (display ". ***" port)
270    (newline port)
271    (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
272    (newline port))
274  (define (test-on-bad-count-simple runner count expected-count)
275    (%test-on-bad-count-write runner count expected-count (current-output-port))
276    (let ((log (test-runner-aux-value runner)))
277      (if (output-port? log)
278          (%test-on-bad-count-write runner count expected-count log))))
280  (define (test-on-bad-end-name-simple runner begin-name end-name)
281    (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
282                              " does not match test-begin " end-name)))
283      (error 'test-on-ban-end-name-simple msg 0)))
285  (define (%test-final-report1 value label port)
286    (if (> value 0)
287        (begin
288          (display label port)
289          (display value port)
290          (newline port))))
292  (define (%test-final-report-simple runner port)
293    (%test-final-report1 (test-runner-pass-count runner)
294                         "# of expected passes      " port)
295    (%test-final-report1 (test-runner-xfail-count runner)
296                         "# of expected failures    " port)
297    (%test-final-report1 (test-runner-xpass-count runner)
298                         "# of unexpected successes " port)
299    (%test-final-report1 (test-runner-fail-count runner)
300                         "# of unexpected failures  " port)
301    (%test-final-report1 (test-runner-skip-count runner)
302                         "# of skipped tests        " port))
304  (define (test-on-final-simple runner)
305    (%test-final-report-simple runner (current-output-port))
306    (let ((log (test-runner-aux-value runner)))
307      (if (output-port? log)
308          (%test-final-report-simple runner log))))
310  (define (%test-format-line runner)
311    (let* ((line-info (test-runner-result-alist runner))
312           (source-file (assq 'source-file line-info))
313           (source-line (assq 'source-line line-info))
314           (file (if source-file (cdr source-file) "")))
315      (if source-line
316          (string-append file ":"
317                         (number->string (cdr source-line)) ": ")
318          "")))
320  (define (%test-end suite-name line-info)
321    (let* ((r (test-runner-get))
322           (groups (test-runner-group-stack r))
323           (line (%test-format-line r)))
324      (test-runner-result-alist-set! r line-info)
325      (if (null? groups)
326          (let ((msg (string-append line "test-end not in a group")))
327            (error '%test-end msg 0)))
328      (when (and suite-name 
329                 (not (equal? suite-name (car groups))))
330        ((test-runner-on-bad-end-name r) r suite-name (car groups)))
331      (let* ((count-list (test-runner-count-list r))
332             (expected-count (cdar count-list))
333             (saved-count (caar count-list))
334             (group-count (- (test-runner-total-count r) saved-count)))
335        (if (and expected-count
336                 (not (= expected-count group-count)))
337            ((test-runner-on-bad-count r) r group-count expected-count))
338        ((test-runner-on-group-end r) r)
339        (test-runner-group-stack-set! r (cdr (test-runner-group-stack r)))
340        (test-runner-skip-list-set! r (car (test-runner-skip-save r)))
341        (test-runner-skip-save-set! r (cdr (test-runner-skip-save r)))
342        (test-runner-fail-list-set! r (car (test-runner-fail-save r)))
343        (test-runner-fail-save-set! r (cdr (test-runner-fail-save r)))
344        (test-runner-count-list-set! r (cdr count-list))
345        (if (null? (test-runner-group-stack r))
346            ((test-runner-on-final r) r)))))
348  (define-syntax test-group
349    (syntax-rules ()
350      ((test-group suite-name . body)
351       (let ((r (test-runner-current)))
352         ;; Ideally should also set line-number, if available.
353         (test-runner-result-alist-set! r (list (cons 'test-name suite-name)))
354         (if (%test-should-execute r)
355             (dynamic-wind
356                 (lambda () (test-begin suite-name))
357                 (lambda () . body)
358                 (lambda () (test-end  suite-name))))))))
360  (define-syntax test-group-with-cleanup
361    (syntax-rules ()
362      ((test-group-with-cleanup suite-name form cleanup-form)
363       (test-group suite-name
364                   (dynamic-wind
365                       (lambda () #f)
366                       (lambda () form)
367                       (lambda () cleanup-form))))
368      ((test-group-with-cleanup suite-name cleanup-form)
369       (test-group-with-cleanup suite-name #f cleanup-form))
370      ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
371       (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
373  (define (test-on-test-begin-simple runner)
374    (let ((log (test-runner-aux-value runner)))
375      (if (output-port? log)
376          (let* ((results (test-runner-result-alist runner))
377                 (source-file (assq 'source-file results))
378                 (source-line (assq 'source-line results))
379                 (source-form (assq 'source-form results))
380                 (test-name (assq 'test-name results)))
381            (display "Test begin:" log)
382            (newline log)
383            (if test-name (%test-write-result1 test-name log))
384            (if source-file (%test-write-result1 source-file log))
385            (if source-line (%test-write-result1 source-line log))
386            (if source-file (%test-write-result1 source-form log))))))
388  (define-syntax test-result-ref
389    (syntax-rules ()
390      ((test-result-ref runner pname)
391       (test-result-ref runner pname #f))
392      ((test-result-ref runner pname default)
393       (let ((p (assq pname (test-runner-result-alist runner))))
394         (if p (cdr p) default)))))
396  (define (test-on-test-end-simple runner)
397    (let ((log (test-runner-aux-value runner))
398          (kind (test-result-ref runner 'result-kind)))
399      (if (memq kind '(fail xpass))
400          (let* ((results (test-runner-result-alist runner))
401                 (source-file (assq 'source-file results))
402                 (source-line (assq 'source-line results))
403                 (test-name (assq 'test-name results)))
404            (if (or source-file source-line)
405                (begin
406                  (if source-file (display (cdr source-file)))
407                  (display ":")
408                  (if source-line (display (cdr source-line)))
409                  (display ": ")))
410            (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
411            (if test-name
412                (begin
413                  (display " ")
414                  (display (cdr test-name))))
415            (newline)))
416      (if (output-port? log)
417          (begin
418            (display "Test end:" log)
419            (newline log)
420            (let loop ((list (test-runner-result-alist runner)))
421              (if (pair? list)
422                  (let ((pair (car list)))
423                    ;; Write out properties not written out by on-test-begin.
424                    (if (not (memq (car pair)
425                                   '(test-name source-file source-line source-form)))
426                        (%test-write-result1 pair log))
427                    (loop (cdr list)))))))))
429  (define (%test-write-result1 pair port)
430    (display "  " port)
431    (display (car pair) port)
432    (display ": " port)
433    (write (cdr pair) port)
434    (newline port))
436  (define (test-result-set! runner pname value)
437    (let* ((alist (test-runner-result-alist runner))
438           (p (assq pname alist)))
439      (if p
440          (set-cdr! p value)
441          (test-runner-result-alist-set! runner (cons (cons pname value) alist)))))
443  (define (test-result-clear runner)
444    (test-runner-result-alist-set! runner '()))
446  (define (test-result-remove runner pname)
447    (let* ((alist (test-runner-result-alist runner))
448           (p (assq pname alist)))
449      (if p
450          (test-runner-result-alist-set! runner
451                                         (let loop ((r alist))
452                                           (if (eq? r p) (cdr r)
453                                               (cons (car r) (loop (cdr r)))))))))
455  (define (test-result-kind . rest)
456    (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
457      (test-result-ref runner 'result-kind)))
459  (define (test-passed? . rest)
460    (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
461      (memq (test-result-ref runner 'result-kind) '(pass xpass))))
463  (define (%test-report-result)
464    (let* ((r (test-runner-get))
465           (result-kind (test-result-kind r)))
466      (case result-kind
467        ((pass)
468         (test-runner-pass-count-set! r (+ 1 (test-runner-pass-count r))))
469        ((fail)
470         (test-runner-fail-count-set!    r (+ 1 (test-runner-fail-count r))))
471        ((xpass)
472         (test-runner-xpass-count-set! r (+ 1 (test-runner-xpass-count r))))
473        ((xfail)
474         (test-runner-xfail-count-set! r (+ 1 (test-runner-xfail-count r))))
475        (else
476         (test-runner-skip-count-set! r (+ 1 (test-runner-skip-count r)))))
477      (test-runner-total-count-set! r (+ 1 (test-runner-total-count r)))
478      ((test-runner-on-test-end r) r)))
480  (define-syntax %test-evaluate-with-catch
481    (syntax-rules ()
482      ((%test-evaluate-with-catch test-expression)
483       (with-exception-handler (lambda (e) #f)
484                               (lambda () 
485                                 test-expression)))))
487  (define (%test-on-test-begin r)
488    (%test-should-execute r)
489    ((test-runner-on-test-begin r) r)
490    (not (eq? 'skip (test-result-ref r 'result-kind))))
492  (define (%test-on-test-end r result)
493    (test-result-set! r 'result-kind
494                      (if (eq? (test-result-ref r 'result-kind) 'xfail)
495                          (if result 'xpass 'xfail)
496                          (if result 'pass 'fail))))
498  (define (test-runner-test-name runner)
499    (test-result-ref runner 'test-name ""))
501  (define-syntax %test-comp2body
502    (syntax-rules ()
503      ((%test-comp2body r comp expected expr)
504       (let ()
505         (if (%test-on-test-begin r)
506             (let ((exp expected))
507               (test-result-set! r 'expected-value exp)
508               (let ((res (%test-evaluate-with-catch expr)))
509                 (test-result-set! r 'actual-value res)
510                 (%test-on-test-end r (comp exp res)))))
511         (%test-report-result)))))
513  (define (%test-approximimate= error)
514    (lambda (value expected)
515      (and (>= value (- expected error))
516           (<= value (+ expected error)))))
518  (define-syntax %test-comp1body
519    (syntax-rules ()
520      ((%test-comp1body r expr)
521       (let ()
522         (if (%test-on-test-begin r)
523             (let ()
524               (let ((res (%test-evaluate-with-catch expr)))
525                 (test-result-set! r 'actual-value res)
526                 (%test-on-test-end r res))))
527         (%test-report-result)))))
529  (define-syntax test-end
530    (syntax-rules ()
531      ((test-end suite-name line)                 
532       (%test-end suite-name line))
533      ((test-end suite-name)
534       (%test-end suite-name 0))
535      ((test-end)
536       (%test-end #f 0))))
538  (define-syntax test-assert
539    (syntax-rules ()
540      ((test-assert tname expr)
541       (let ((r (test-runner-get)))
542         (test-runner-result-alist-set! r (cons (cons 'test-name tname) 0))
543         (%test-comp1body r expr)))
544      ((test-assert expr)
545       (let ((r (test-runner-get)))
546         (test-runner-result-alist-set! r 0)
547         (%test-comp1body r expr)))))
549  ;;      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
550  ;;        (((mac tname expr) line)
551  ;;         (syntax
552  ;;          (let* ((r (test-runner-get))
553  ;;                 (name tname))
554  ;;            (test-runner-result-alist-set! r (cons (cons 'test-name tname) line))
555  ;;            (%test-comp1body r expr))))
556  ;;        (((mac expr) line)
557  ;;         (syntax
558  ;;          (let* ((r (test-runner-get)))
559  ;;            (test-runner-result-alist-set! r line)
560  ;;            (%test-comp1body r expr)))))))
563  (define-syntax test-binop
564    (syntax-rules ()
565      ((test-bino tname binop expected expr)
566       (let ((r (test-runner-get)))
567         (test-runner-result-alist-set! r (cons (cons 'test-name tname) 0))
568         (%test-comp2body r binop expected expr)))))          
570  (define-syntax test-eq?
571    (syntax-rules ()
572      ((test-eq? tname expected expr)
573       (test-binop tname eq? expected expr))))
575  (define-syntax test-eqv?
576    (syntax-rules ()
577      ((test-eqv? tname expected expr)
578       (test-binop tname eqv? expected expr))))
580  (define-syntax test-equal?
581    (syntax-rules ()
582      ((test-equal? tname expected expr)
583       (test-binop tname equal? expected expr))))
585  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
586    (lambda (x)
587      (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
588        (((mac tname expected expr error) line)
589         (syntax
590          (let* ((r (test-runner-get))
591                 (name tname))
592            (test-runner-result-alist-set! r (cons (cons 'test-name tname) line))
593            (%test-comp2body r (%test-approximimate= error) expected expr))))
594        (((mac expected expr error) line)
595         (syntax
596          (let* ((r (test-runner-get)))
597            (test-runner-result-alist-set! r line)
598            (%test-comp2body r (%test-approximimate= error) expected expr)))))))
601  (define-syntax %test-error
602    (syntax-rules ()
603      ((%test-error r etype expr)
604       (%test-comp1body r (call-with-current-continuation (lambda (return)
605                                                            with-exception-handler (lambda (h) (display "BANG!!!")(newline)(return #t))
606                                                            (lambda ()
607                                                              (let ()
608                                                                (test-result-set! r 'actual-value (expr))
609                                                                #f))))))))
611  (define-syntax test-error
612    (lambda (stx)
613      (syntax-case stx ()
614        ((test-error tname etype expr)
615         (syntax
616          (let ((r (test-runner-get)))
617            (test-runner-result-alist-set! r (cons (cons 'test-name tname) 0))
618            (%test-error r etype expr)))))))
621  (define (test-apply first . rest)
622    (if (test-runner? first)
623        (test-with-runner first (apply test-apply rest))
624        (let ((r (test-runner-current)))
625          (if r
626              (let ((run-list (test-runner-run-list r)))
627                (cond ((null? rest)
628                       (test-runner-run-list-set! r (reverse run-list))
629                       (first)) ;; actually apply procedure thunk
630                      (else
631                       (test-runner-run-list-set!
632                        r
633                        (if (eq? run-list #t) (list first) (cons first run-list)))
634                       (apply test-apply rest)
635                       (test-runner-run-list-set! r run-list))))
636              (let ((r (test-runner-create)))
637                (test-with-runner r (apply test-apply first rest))
638                ((test-runner-on-final r) r))))))
640  (define-syntax test-with-runner
641    (syntax-rules ()
642      ((test-with-runner runner form ...)
643       (let ((saved-runner (test-runner-current)))
644         (dynamic-wind
645             (lambda () (test-runner-current runner))
646             (lambda () form ...)
647             (lambda () (test-runner-current saved-runner)))))))
649 ;;; Predicates
651  (define (%test-match-nth n count)
652    (let ((i 0))
653      (lambda (runner)
654        (set! i (+ i 1))
655        (and (>= i n) (< i (+ n count))))))
657  (define-syntax test-match-nth
658    (syntax-rules ()
659      ((test-match-nth n)
660       (test-match-nth n 1))
661      ((test-match-nth n count)
662       (%test-match-nth n count))))
664  (define (%test-match-all . pred-list)
665    (lambda (runner)
666      (let ((result #t))
667        (let loop ((l pred-list))
668          (if (null? l)
669              result
670              (begin
671                (if (not ((car l) runner))
672                    (set! result #f))
673                (loop (cdr l))))))))
675  (define-syntax test-match-all
676    (syntax-rules ()
677      ((test-match-all pred ...)
678       (%test-match-all (%test-as-specifier pred) ...))))
680  (define (%test-match-any . pred-list)
681    (lambda (runner)
682      (let ((result #f))
683        (let loop ((l pred-list))
684          (if (null? l)
685              result
686              (begin
687                (if ((car l) runner)
688                    (set! result #t))
689                (loop (cdr l))))))))
691  (define-syntax test-match-any
692    (syntax-rules ()
693      ((test-match-any pred ...)
694       (%test-match-any (%test-as-specifier pred) ...))))
696  ;; Coerce to a predicate function:
697  (define (%test-as-specifier specifier)
698    (cond ((procedure? specifier) specifier)
699          ((integer? specifier) (test-match-nth 1 specifier))
700          ((string? specifier) (test-match-name specifier))
701          (else
702           (error "not a valid test specifier"))))
704  (define-syntax test-skip
705    (syntax-rules ()
706      ((test-skip pred ...)
707       (let ((runner (test-runner-get)))
708         (test-runner-skip-list-set! runner
709                                     (cons (test-match-all (%test-as-specifier pred)  ...)
710                                           (test-runner-skip-list runner)))))))
712  (define-syntax test-expect-fail
713    (syntax-rules ()
714      ((test-expect-fail pred ...)
715       (let ((runner (test-runner-get)))
716         (test-runner-fail-list-set! runner
717                                     (cons (test-match-all (%test-as-specifier pred)  ...)
718                                           (test-runner-fail-list runner)))))))
720  (define (test-match-name name)
721    (lambda (runner)
722      (equal? name (test-runner-test-name runner))))
724  ;;  (define (test-read-eval-string string)
725  ;;    (let* ((port (open-input-string string))
726  ;;           (form (read port)))
727  ;;      (if (eof-object? (get-char port))
728  ;;          (eval form)
729  ;;          (error 'test-read-eval-string "(not at eof)" 0))))
733 ;; Copyright (c) 2005, 2006 Per Bothner
735 ;; Permission is hereby granted, free of charge, to any person
736 ;; obtaining a copy of this software and associated documentation
737 ;; files (the "Software"), to deal in the Software without
738 ;; restriction, including without limitation the rights to use, copy,
739 ;; modify, merge, publish, distribute, sublicense, and/or sell copies
740 ;; of the Software, and to permit persons to whom the Software is
741 ;; furnished to do so, subject to the following conditions:
743 ;; The above copyright notice and this permission notice shall be
744 ;; included in all copies or substantial portions of the Software.
746 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
747 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
748 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
749 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
750 ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
751 ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
752 ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
753 ;; SOFTWARE.