1 ;; Port of SRFI-78 to ERR5RS. See bottom for copyright information.
4 (rl3 test unit-tests utils)
13 (define (%test-source-line2 form)
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?
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)
61 (for (rnrs exceptions)
63 (only (rnrs io simple)
65 display newline write)
71 eof-object? output-port?)
72 (for (rnrs syntax-case)
74 (for (rl3 test unit-tests utils)
78 (only (rl3 env parameters)
80 (only (rnrs mutable-pairs)
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)
91 (on-test-begin) (on-test-end)
92 ;; call-back when entering a group. Takes (runeer suite-name count)
94 ;; call-back when leaving a group
104 (define test-runner-alloc
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
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))
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
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)
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
167 (let ((r (test-runner-current)))
169 (error "test-runner not initialized - test-begin missing?"))
172 (define (%test-specificier-matches spec runner)
175 (define (test-runner-create)
176 ((test-runner-factory)))
178 (define (%test-any-specifier-matches list runner)
181 (cond ((null? l) result)
183 (if (%test-specificier-matches (car l) runner)
187 ;; Returns #f, #t, or 'xfail.
188 (define (%test-should-execute runner)
189 (let ((run (test-runner-run-list runner)))
191 (not (or (eqv? run #t)
192 (%test-any-specifier-matches run runner)))
193 (%test-any-specifier-matches
194 (test-runner-skip-list runner)
196 (test-result-set! runner 'result-kind 'skip)
198 ((%test-any-specifier-matches
199 (test-runner-fail-list runner)
201 (test-result-set! runner 'result-kind 'xfail)
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)
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
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))
232 (display "%%%% Starting test ")
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)
242 (test-runner-aux-value-set! runner log-file)
243 (display " (Writing full log to \"")
244 (display log-file-name)
247 (let ((log (test-runner-aux-value runner)))
248 (if (output-port? log)
250 (display "Group begin: " log)
251 (display suite-name log)
255 (define (test-on-group-end-simple runner)
256 (let ((log (test-runner-aux-value runner)))
257 (if (output-port? log)
259 (display "Group end: " log)
260 (display (car (test-runner-group-stack runner)) log)
264 (define (%test-on-bad-count-write runner count expected-count port)
265 (display "*** Total number of tests was " port)
267 (display " but should be " port)
268 (display expected-count port)
269 (display ". ***" port)
271 (display "*** Discrepancy indicates testsuite error or exceptions. ***" 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)
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) "")))
316 (string-append file ":"
317 (number->string (cdr source-line)) ": ")
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)
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
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)
356 (lambda () (test-begin suite-name))
358 (lambda () (test-end suite-name))))))))
360 (define-syntax test-group-with-cleanup
362 ((test-group-with-cleanup suite-name form cleanup-form)
363 (test-group suite-name
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)
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
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)
406 (if source-file (display (cdr source-file)))
408 (if source-line (display (cdr source-line)))
410 (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
414 (display (cdr test-name))))
416 (if (output-port? log)
418 (display "Test end:" log)
420 (let loop ((list (test-runner-result-alist runner)))
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)
431 (display (car pair) port)
433 (write (cdr pair) port)
436 (define (test-result-set! runner pname value)
437 (let* ((alist (test-runner-result-alist runner))
438 (p (assq pname alist)))
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)))
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)))
468 (test-runner-pass-count-set! r (+ 1 (test-runner-pass-count r))))
470 (test-runner-fail-count-set! r (+ 1 (test-runner-fail-count r))))
472 (test-runner-xpass-count-set! r (+ 1 (test-runner-xpass-count r))))
474 (test-runner-xfail-count-set! r (+ 1 (test-runner-xfail-count r))))
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
482 ((%test-evaluate-with-catch test-expression)
483 (with-exception-handler (lambda (e) #f)
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
503 ((%test-comp2body r comp expected expr)
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
520 ((%test-comp1body r expr)
522 (if (%test-on-test-begin r)
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
531 ((test-end suite-name line)
532 (%test-end suite-name line))
533 ((test-end suite-name)
534 (%test-end suite-name 0))
538 (define-syntax test-assert
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)))
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)
552 ;; (let* ((r (test-runner-get))
554 ;; (test-runner-result-alist-set! r (cons (cons 'test-name tname) line))
555 ;; (%test-comp1body r expr))))
556 ;; (((mac expr) line)
558 ;; (let* ((r (test-runner-get)))
559 ;; (test-runner-result-alist-set! r line)
560 ;; (%test-comp1body r expr)))))))
563 (define-syntax test-binop
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?
572 ((test-eq? tname expected expr)
573 (test-binop tname eq? expected expr))))
575 (define-syntax test-eqv?
577 ((test-eqv? tname expected expr)
578 (test-binop tname eqv? expected expr))))
580 (define-syntax test-equal?
582 ((test-equal? tname expected expr)
583 (test-binop tname equal? expected expr))))
585 (define-syntax test-approximate ;; FIXME - needed for non-Kawa
587 (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
588 (((mac tname expected expr error) line)
590 (let* ((r (test-runner-get))
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)
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
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))
608 (test-result-set! r 'actual-value (expr))
611 (define-syntax test-error
614 ((test-error tname etype expr)
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)))
626 (let ((run-list (test-runner-run-list r)))
628 (test-runner-run-list-set! r (reverse run-list))
629 (first)) ;; actually apply procedure thunk
631 (test-runner-run-list-set!
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
642 ((test-with-runner runner form ...)
643 (let ((saved-runner (test-runner-current)))
645 (lambda () (test-runner-current runner))
647 (lambda () (test-runner-current saved-runner)))))))
651 (define (%test-match-nth n count)
655 (and (>= i n) (< i (+ n count))))))
657 (define-syntax test-match-nth
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)
667 (let loop ((l pred-list))
671 (if (not ((car l) runner))
675 (define-syntax test-match-all
677 ((test-match-all pred ...)
678 (%test-match-all (%test-as-specifier pred) ...))))
680 (define (%test-match-any . pred-list)
683 (let loop ((l pred-list))
691 (define-syntax test-match-any
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))
702 (error "not a valid test specifier"))))
704 (define-syntax test-skip
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
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)
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))
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