blob: f2213884620dbe962ae7fc70f73a7ec41410af7c (
plain) (
blame)
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
(define-library (csc testing)
(export
define-test
errorf
fatalf
test-main
subtest)
(import (scheme base)
(only (csc format)
printf
sprintf)
(only (csc vec)
vec
vec-append
vec-length
vec-ref))
(begin
(define *all-tests-succeeded* #t)
(define (set-all-succeeded! val) (set! *all-tests-succeeded* val))
(define-record-type <test-handle>
(make-test-handle test-name subtest-name succeeded subtests-succeeded)
test-handle?
(test-name base-test-name)
(subtest-name subtest-name)
(succeeded test-succeeded? set-succeeded!)
(subtests-succeeded subtests-succeeded set-subtests-succeeded!))
(define (test-name t)
(let ((sn (subtest-name t)))
(if (equal? sn "")
(base-test-name t)
(sprintf "{}/{}" (base-test-name t) sn))))
(define-record-type <test-error>
(make-test-error)
test-error?)
(define-syntax define-test
(syntax-rules ()
((_ (name t) body ...)
(let ((t (make-test-handle (symbol->string 'name) "" #t (vec))))
(printf "=== RUN {}\n" 'name)
(guard (e ((test-error? e))
#;(else
(errorf t "{}" e)))
body ...)
(if (test-succeeded? t)
(printf "--- PASS: {}\n" 'name)
(begin
(printf "--- FAIL: {}\n" 'name)
(set-all-succeeded! #f)))
(do ((i 0 (+ 1 i)))
((>= i (vec-length (subtests-succeeded t))))
(printf " --- {}: {}/{}\n"
(if (cdr (vec-ref (subtests-succeeded t) i)) "PASS" "FAIL")
'name
(car (vec-ref (subtests-succeeded t) i))))))))
(define-syntax subtest
(syntax-rules ()
((_ t name body ...)
(let ((old-t t)
(t (make-test-handle (test-name t) name #t (vec))))
(printf "=== RUN {}\n" (test-name t))
(guard (e ((test-error? e))
#;(else
(errorf t "{}" e)))
body ...)
(let ((succ (test-succeeded? t)))
(set-subtests-succeeded! old-t (vec-append (subtests-succeeded old-t) (cons name succ)))
(unless succ
(set-succeeded! old-t #f)))))))
(define-syntax errorf
(syntax-rules ()
((_ t format-string format-args ...)
(begin
(set-succeeded! t #f)
(printf "{}: {}\n" (test-name t) (sprintf format-string format-args ...))))))
(define-syntax fatalf
(syntax-rules ()
((_ t format-string format-args ...)
(begin
(errorf t format-string format-args ...)
(raise (make-test-error))))))
(define (test-main)
(if *all-tests-succeeded*
(printf "PASS\n")
(printf "FAIL\n")))))
|
