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
|
;;; Shim for SRFI-64 for unhygenic, single threaded systems.
(define tests-passed 0)
(define tests-failed 0)
(define current-test-name '())
(define-syntax test-equal
(lambda (name-e expected-e got-e)
(let ((name* (gensym 'name))
(expected* (gensym 'expected))
(got* (gensym 'got))
(passed?* (gensym 'passed?)))
`(let* ((,name* ,name-e)
(,expected* ,expected-e)
(,got* ,got-e)
(,passed?* (equal? ,expected* ,got*)))
(if ,passed?*
(begin
(set! tests-passed (+ 1 tests-passed))
(pretty-print
(list 'name (cons ,name* current-test-name)
'passed)))
(begin
(set! tests-failed (+ 1 tests-failed))
(pretty-print
(list 'name (cons ,name* current-test-name)
'failed
(list (list 'expected ,expected*)
(list 'got ,got*)))
'data)))
(newline)))))
(define-syntax test-group
(lambda (name-e . body)
(let ((old-test-name* (gensym 'old-test-name))
(name* (gensym 'name)))
`(let ((,old-test-name* current-test-name)
(,name* ,name-e))
(pretty-print (list 'entering ,name*) 'data)
(set! current-test-name (cons ,name* ,old-test-name*))
,@body
(set! current-test-name ,old-test-name*)
(pretty-print
(list 'leaving ,name*
(list 'accumulated
(list 'passed tests-passed)
(list 'failed tests-failed)))
'data)
(newline)))))
(load "../RPS.scm")
(load "../macros.scm")
(load "body.scm")
|
