1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; ,config ,load debug/test.scm
(define-structure testing (export (test :syntax) lost?)
(open scheme handle conditions)
(open i/o)
(begin
(define *lost?* #f)
(define (lost?) *lost?*)
(define (run-test string compare want thunk)
(let ((out (current-error-port)))
(display "[" out)
(display string out)
(force-output out)
(let ((result
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (condition punt)
(if (serious-condition? condition)
(k condition)
(punt)))
thunk)))))
(if (not (compare want result))
(begin (display "Test ") (write string) (display " failed.") (newline)
(display "Wanted ") (write want)
(display ", but got ") (write result) (display ".")
(newline)
(set! *lost?* #t))))
(display "]" out) (newline out)))
(define-syntax test
(syntax-rules ()
((test ?string ?compare ?want ?exp)
(run-test ?string ?compare ?want (lambda () ?exp)))))
))
|
