Skip to content

Commit 6963a49

Browse files
codecopcodecop
committed
Work in progress assert for Chicken Scheme. This is as far I got in the C64 Parser project.
1 parent 33453ce commit 6963a49

File tree

3 files changed

+252
-0
lines changed

3 files changed

+252
-0
lines changed

‎assert-chicken.scm

Lines changed: 37 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,37 @@
1+
;;;
2+
;;; Unit test framework for Scheme R5RS, Chicken extension.
3+
;;; Copyright (c) 2015, Peter Kofler, http://www.code-cop.org/
4+
;;; BSD licensed.
5+
;;;
6+
(include "assert-r5rs.scm")
7+
8+
(define (-error->string ex)
9+
(cond ((symbol? ex) (symbol->string ex))
10+
((string? ex) ex)
11+
;; Chicken specific code
12+
;; TODO Chicken Scheme exception types
13+
;; ((type-exception? ex) (string-append "expected " (-error->string (type-exception-type-id ex)))) ; type name
14+
;; ((exn ex) "xxx")
15+
;; see https://wiki.call-cc.org/man/4/Exceptions#exception-handlers
16+
(else (pp ex)
17+
"<unknown exception type>")))
18+
19+
(define (-run-with-exception-handler handler body)
20+
;; Chicken specific code
21+
(let ((exn-message-comparison '()))
22+
(handle-exceptions exn
23+
(set! exn-message-comparison (handler exn))
24+
(body))
25+
exn-message-comparison))
26+
27+
(define (assert-raise expected-ex body)
28+
(define (ex-handler ex)
29+
(let ((expected-message (-error->string expected-ex))
30+
(actual-message (-error->string ex)))
31+
(check (-make-string-message "raise " -error->string expected-ex ex)
32+
(string=? expected-message actual-message))))
33+
(define (ex-body)
34+
(body)
35+
(error "no raise in body"))
36+
(lambda ()
37+
(-run-with-exception-handler ex-handler ex-body)))

‎assert-test-chicken.scm

Lines changed: 214 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,214 @@
1+
(include "assert-chicken.scm")
2+
3+
(define (test-failure name expected-message body)
4+
(test-case name
5+
(assert-raise (-make-assertion-error expected-message)
6+
body)))
7+
8+
(test-failure "(fail) throws AssertionError with message"
9+
"message"
10+
(lambda ()
11+
(fail "message")))
12+
13+
(test-case "(check) should not fail on #t condition"
14+
(lambda ()
15+
(check "should not fail" #t)))
16+
17+
(test-failure "(check) fails on #f condition"
18+
"message"
19+
(lambda ()
20+
(check "message" #f)))
21+
22+
(test-case "(assert=) equals number"
23+
(assert= 1 1))
24+
25+
(test-failure "(assert=) fails"
26+
"expected:<1> but was:<2>"
27+
(assert= 1 2))
28+
29+
(test-case "(assert-string=) equals string"
30+
(assert-string= "abc" "abc"))
31+
32+
(test-failure "(assert-string=) fails"
33+
"expected:<abc> but was:<123>"
34+
(assert-string= "abc" "123"))
35+
36+
(test-case "(assert-inexact=) equals number"
37+
(assert-inexact= 1. 1.1 0.11))
38+
39+
(test-failure "(assert-inexact=) fails"
40+
"in range expected:<[.99-1.01]> but was:<1.1>"
41+
(assert-inexact= 1. 1.1 0.01))
42+
43+
(test-case "(assert-list=)"
44+
(assert-list= number->string
45+
=
46+
(list 1 2)
47+
(list 1 2)))
48+
49+
(test-failure "(assert-list=) fails on wrong element"
50+
"2. item expected:<3> but was:<2>"
51+
(assert-list= number->string
52+
=
53+
(list 1 3)
54+
(list 1 2)))
55+
56+
(test-failure "(assert-list=) fails on short list"
57+
"3. item expected:<more elements> but was:<no more elements>"
58+
(assert-list= number->string
59+
=
60+
(list 1 2 3)
61+
(list 1 2)))
62+
63+
(test-failure "(assert-list=) fails on long list"
64+
"2. item expected:<no more elements> but was:<more elements>"
65+
(assert-list= number->string
66+
=
67+
(list 1)
68+
(list 1 2)))
69+
70+
(test-case "(assert-list=) recursive"
71+
(assert-list= number->string
72+
=
73+
(list 1 (list 2 3))
74+
(list 1 (list 2 3))))
75+
76+
(test-failure "(assert-list=) recursive fails on wrong element type"
77+
"2. item expected:<a sublist> but was:<no sublist>"
78+
(assert-list= number->string
79+
=
80+
(list 1 (list 3))
81+
(list 1 2)))
82+
83+
(test-failure "(assert-list=) recursive fails on wrong element"
84+
"22. item expected:<3> but was:<4>"
85+
(assert-list= number->string
86+
=
87+
(list 1 (list 2 3))
88+
(list 1 (list 2 4))))
89+
90+
(test-case "(assert-list=) with strings"
91+
(assert-list= values
92+
string=?
93+
(list "a")
94+
(list "a"))
95+
(assert-string-list= (list "a")
96+
(list "a")))
97+
98+
(test-case "(assert-true)"
99+
(assert-true #t))
100+
101+
(test-failure "(assert-true) fails"
102+
"expected:<true> but was:<false>"
103+
(assert-true #f))
104+
105+
(test-case "(assert-false)"
106+
(assert-false #f))
107+
108+
(test-failure "(assert-false) fails"
109+
"expected:<false> but was:<true>"
110+
(assert-false #t))
111+
112+
(test-case "(assert-null)"
113+
(assert-null '()))
114+
115+
(test-failure "(assert-null) fails"
116+
"expected:<null> but was:<not null>"
117+
(assert-null (list 1)))
118+
119+
(test-case "(assert-not-null)"
120+
(assert-not-null (list 1)))
121+
122+
(test-failure "(assert-not-null) fails"
123+
"expected:<not null> but was:<null>"
124+
(assert-not-null '()))
125+
126+
(test-case "(assert-raise) on raise symbol"
127+
(assert-raise 'a (lambda ()
128+
(raise 'a))))
129+
130+
(test-case "(assert-raise) on raise string"
131+
(assert-raise "a" (lambda ()
132+
(raise 'a))))
133+
134+
(test-case "(assert-raise) on error symbol"
135+
(assert-raise 'a (lambda ()
136+
(error 'a))))
137+
138+
(test-case "(assert-raise) on error string"
139+
(assert-raise "a" (lambda ()
140+
(error "a"))))
141+
142+
(test-failure "(assert-raise) fails"
143+
"raise expected:<a> but was:<b>"
144+
(assert-raise 'a (lambda ()
145+
(raise 'b))))
146+
147+
(test-failure "(assert-raise) fails when no raise"
148+
"raise expected:<a> but was:<no raise in body>"
149+
(assert-raise 'a (lambda ()
150+
(+ 1 1))))
151+
152+
(test-case "(assert-raise) on unbound global variable"
153+
(assert-raise 'unbound-global-variable (lambda ()
154+
(unbound-global-variable))))
155+
156+
(test-case "(assert-raise) on type error"
157+
(assert-raise "expected number" (lambda ()
158+
(+ 1 "1"))))
159+
160+
(test-case "(assert-all) allows several assertions"
161+
(assert-all
162+
(assert-true #t)
163+
(assert-true #t)))
164+
165+
(test-failure "(assert-all) evals all assertions"
166+
"expected:<true> but was:<false>"
167+
(lambda ()
168+
(test-case "- inside assert-all"
169+
(assert-all
170+
(assert-true #t)
171+
(assert-true #f)))))
172+
173+
(test-case "(test-case) allows several assertions"
174+
(assert-true #t)
175+
(assert-true #t))
176+
177+
(test-failure "(test-case) evals first assertion"
178+
"expected:<true> but was:<false>"
179+
(lambda ()
180+
(test-case "- inside evals first"
181+
(assert-true #f)
182+
(assert-true #t))))
183+
184+
(test-failure "(test-case) evals second assertion"
185+
"expected:<true> but was:<false>"
186+
(lambda ()
187+
(test-case "- inside evals second"
188+
(assert-true #t)
189+
(assert-true #f)
190+
(assert-true #t))))
191+
192+
(test-failure "(test-case) evals third assertion"
193+
"expected:<true> but was:<false>"
194+
(lambda ()
195+
(test-case "- inside evals third"
196+
(assert-true #t)
197+
(assert-true #t)
198+
(assert-true #f))))
199+
200+
(ignored-test-case "(ignored-test-case) is ignored, else it would fail"
201+
(assert-true #f))
202+
203+
(test-case "(useless-test-case)"
204+
(lambda () #f))
205+
206+
(test-failure "bug (assert-string-list=) fails on extra empty list"
207+
"124. item expected:<no more elements> but was:<more elements>"
208+
(assert-string-list= '(("4840" ("PRINT" ("\" \"") ";")))
209+
'(("4840" ("PRINT" ("\" \"") ";" ())))))
210+
211+
(test-failure "bug (assert-string-list=) fails on different element after sublist"
212+
"3. item expected:<3> but was:<x>"
213+
(assert-string-list= '("1" ("2") "3" )
214+
'("1" ("2") "x" )))

‎test_with_chicken.bat

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
"C:\Program Files (x86)\ChickenScheme\bin\csi.exe" -q -b assert-test-chicken.scm

0 commit comments

Comments
 (0)