Commit | Line | Data |
---|---|---|
341c6fdd LC |
1 | ;; Copyright (c) 2005, 2006 Per Bothner |
2 | ;; | |
3 | ;; Permission is hereby granted, free of charge, to any person | |
4 | ;; obtaining a copy of this software and associated documentation | |
5 | ;; files (the "Software"), to deal in the Software without | |
6 | ;; restriction, including without limitation the rights to use, copy, | |
7 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
8 | ;; of the Software, and to permit persons to whom the Software is | |
9 | ;; furnished to do so, subject to the following conditions: | |
10 | ;; | |
11 | ;; The above copyright notice and this permission notice shall be | |
12 | ;; included in all copies or substantial portions of the Software. | |
13 | ;; | |
14 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
15 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
16 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
17 | ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS | |
18 | ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN | |
19 | ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN | |
20 | ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE | |
21 | ;; SOFTWARE. | |
22 | ||
23 | (cond-expand | |
24 | (chicken | |
25 | (require-extension syntax-case)) | |
26 | (guile | |
fd96bc05 | 27 | (use-modules (srfi srfi-9) |
341c6fdd LC |
28 | ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 |
29 | (srfi srfi-39))) | |
30 | (sisc | |
31 | (require-extension (srfi 9 34 35 39))) | |
32 | (kawa | |
33 | (module-compile-options warn-undefined-variable: #t | |
34 | warn-invoke-unknown-method: #t) | |
35 | (provide 'srfi-64) | |
36 | (provide 'testing) | |
37 | (require 'srfi-34) | |
38 | (require 'srfi-35)) | |
39 | (else () | |
40 | )) | |
41 | ||
42 | (cond-expand | |
43 | (kawa | |
44 | (define-syntax %test-export | |
45 | (syntax-rules () | |
46 | ((%test-export test-begin . other-names) | |
47 | (module-export %test-begin . other-names))))) | |
48 | (else | |
49 | (define-syntax %test-export | |
50 | (syntax-rules () | |
51 | ((%test-export . names) (if #f #f)))))) | |
52 | ||
53 | ;; List of exported names | |
54 | (%test-export | |
55 | test-begin ;; must be listed first, since in Kawa (at least) it is "magic". | |
56 | test-end test-assert test-eqv test-eq test-equal | |
57 | test-approximate test-assert test-error test-apply test-with-runner | |
58 | test-match-nth test-match-all test-match-any test-match-name | |
59 | test-skip test-expect-fail test-read-eval-string | |
60 | test-runner-group-path test-group-with-cleanup | |
61 | test-result-ref test-result-set! test-result-clear test-result-remove | |
62 | test-result-kind test-passed? | |
63 | test-log-to-file | |
64 | ; Misc test-runner functions | |
65 | test-runner? test-runner-reset test-runner-null | |
66 | test-runner-simple test-runner-current test-runner-factory test-runner-get | |
67 | test-runner-create test-runner-test-name | |
68 | ;; test-runner field setter and getter functions - see %test-record-define: | |
69 | test-runner-pass-count test-runner-pass-count! | |
70 | test-runner-fail-count test-runner-fail-count! | |
71 | test-runner-xpass-count test-runner-xpass-count! | |
72 | test-runner-xfail-count test-runner-xfail-count! | |
73 | test-runner-skip-count test-runner-skip-count! | |
74 | test-runner-group-stack test-runner-group-stack! | |
75 | test-runner-on-test-begin test-runner-on-test-begin! | |
76 | test-runner-on-test-end test-runner-on-test-end! | |
77 | test-runner-on-group-begin test-runner-on-group-begin! | |
78 | test-runner-on-group-end test-runner-on-group-end! | |
79 | test-runner-on-final test-runner-on-final! | |
80 | test-runner-on-bad-count test-runner-on-bad-count! | |
81 | test-runner-on-bad-end-name test-runner-on-bad-end-name! | |
82 | test-result-alist test-result-alist! | |
83 | test-runner-aux-value test-runner-aux-value! | |
84 | ;; default/simple call-back functions, used in default test-runner, | |
85 | ;; but can be called to construct more complex ones. | |
86 | test-on-group-begin-simple test-on-group-end-simple | |
87 | test-on-bad-count-simple test-on-bad-end-name-simple | |
88 | test-on-final-simple test-on-test-end-simple | |
89 | test-on-final-simple) | |
90 | ||
91 | (cond-expand | |
92 | (srfi-9 | |
93 | (define-syntax %test-record-define | |
94 | (syntax-rules () | |
95 | ((%test-record-define alloc runner? (name index setter getter) ...) | |
96 | (define-record-type test-runner | |
97 | (alloc) | |
98 | runner? | |
99 | (name setter getter) ...))))) | |
100 | (else | |
101 | (define %test-runner-cookie (list "test-runner")) | |
102 | (define-syntax %test-record-define | |
103 | (syntax-rules () | |
104 | ((%test-record-define alloc runner? (name index getter setter) ...) | |
105 | (begin | |
106 | (define (runner? obj) | |
107 | (and (vector? obj) | |
108 | (> (vector-length obj) 1) | |
109 | (eq (vector-ref obj 0) %test-runner-cookie))) | |
110 | (define (alloc) | |
111 | (let ((runner (make-vector 22))) | |
112 | (vector-set! runner 0 %test-runner-cookie) | |
113 | runner)) | |
114 | (begin | |
115 | (define (getter runner) | |
116 | (vector-ref runner index)) ...) | |
117 | (begin | |
118 | (define (setter runner value) | |
119 | (vector-set! runner index value)) ...))))))) | |
120 | ||
121 | (%test-record-define | |
122 | %test-runner-alloc test-runner? | |
123 | ;; Cumulate count of all tests that have passed and were expected to. | |
124 | (pass-count 1 test-runner-pass-count test-runner-pass-count!) | |
125 | (fail-count 2 test-runner-fail-count test-runner-fail-count!) | |
126 | (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) | |
127 | (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) | |
128 | (skip-count 5 test-runner-skip-count test-runner-skip-count!) | |
129 | (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) | |
130 | (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) | |
131 | ;; Normally #t, except when in a test-apply. | |
132 | (run-list 8 %test-runner-run-list %test-runner-run-list!) | |
133 | (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) | |
134 | (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) | |
135 | (group-stack 11 test-runner-group-stack test-runner-group-stack!) | |
136 | (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) | |
137 | (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) | |
138 | ;; Call-back when entering a group. Takes (runner suite-name count). | |
139 | (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) | |
140 | ;; Call-back when leaving a group. | |
141 | (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) | |
142 | ;; Call-back when leaving the outermost group. | |
143 | (on-final 16 test-runner-on-final test-runner-on-final!) | |
144 | ;; Call-back when expected number of tests was wrong. | |
145 | (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) | |
146 | ;; Call-back when name in test=end doesn't match test-begin. | |
147 | (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) | |
148 | ;; Cumulate count of all tests that have been done. | |
149 | (total-count 19 %test-runner-total-count %test-runner-total-count!) | |
150 | ;; Stack (list) of (count-at-start . expected-count): | |
151 | (count-list 20 %test-runner-count-list %test-runner-count-list!) | |
152 | (result-alist 21 test-result-alist test-result-alist!) | |
153 | ;; Field can be used by test-runner for any purpose. | |
154 | ;; test-runner-simple uses it for a log file. | |
155 | (aux-value 22 test-runner-aux-value test-runner-aux-value!) | |
156 | ) | |
157 | ||
158 | (define (test-runner-reset runner) | |
159 | (test-runner-pass-count! runner 0) | |
160 | (test-runner-fail-count! runner 0) | |
161 | (test-runner-xpass-count! runner 0) | |
162 | (test-runner-xfail-count! runner 0) | |
163 | (test-runner-skip-count! runner 0) | |
164 | (%test-runner-total-count! runner 0) | |
165 | (%test-runner-count-list! runner '()) | |
166 | (%test-runner-run-list! runner #t) | |
167 | (%test-runner-skip-list! runner '()) | |
168 | (%test-runner-fail-list! runner '()) | |
169 | (%test-runner-skip-save! runner '()) | |
170 | (%test-runner-fail-save! runner '()) | |
171 | (test-runner-group-stack! runner '())) | |
172 | ||
173 | (define (test-runner-group-path runner) | |
174 | (reverse (test-runner-group-stack runner))) | |
175 | ||
176 | (define (%test-null-callback runner) #f) | |
177 | ||
178 | (define (test-runner-null) | |
179 | (let ((runner (%test-runner-alloc))) | |
180 | (test-runner-reset runner) | |
181 | (test-runner-on-group-begin! runner (lambda (runner name count) #f)) | |
182 | (test-runner-on-group-end! runner %test-null-callback) | |
183 | (test-runner-on-final! runner %test-null-callback) | |
184 | (test-runner-on-test-begin! runner %test-null-callback) | |
185 | (test-runner-on-test-end! runner %test-null-callback) | |
186 | (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) | |
187 | (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) | |
188 | runner)) | |
189 | ||
190 | ;; Not part of the specification. FIXME | |
191 | ;; Controls whether a log file is generated. | |
192 | (define test-log-to-file #t) | |
193 | ||
194 | (define (test-runner-simple) | |
195 | (let ((runner (%test-runner-alloc))) | |
196 | (test-runner-reset runner) | |
197 | (test-runner-on-group-begin! runner test-on-group-begin-simple) | |
198 | (test-runner-on-group-end! runner test-on-group-end-simple) | |
199 | (test-runner-on-final! runner test-on-final-simple) | |
200 | (test-runner-on-test-begin! runner test-on-test-begin-simple) | |
201 | (test-runner-on-test-end! runner test-on-test-end-simple) | |
202 | (test-runner-on-bad-count! runner test-on-bad-count-simple) | |
203 | (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) | |
204 | runner)) | |
205 | ||
206 | (cond-expand | |
207 | (srfi-39 | |
208 | (define test-runner-current (make-parameter #f)) | |
209 | (define test-runner-factory (make-parameter test-runner-simple))) | |
210 | (else | |
211 | (define %test-runner-current #f) | |
212 | (define-syntax test-runner-current | |
213 | (syntax-rules () | |
214 | ((test-runner-current) | |
215 | %test-runner-current) | |
216 | ((test-runner-current runner) | |
217 | (set! %test-runner-current runner)))) | |
218 | (define %test-runner-factory test-runner-simple) | |
219 | (define-syntax test-runner-factory | |
220 | (syntax-rules () | |
221 | ((test-runner-factory) | |
222 | %test-runner-factory) | |
223 | ((test-runner-factory runner) | |
224 | (set! %test-runner-factory runner)))))) | |
225 | ||
226 | ;; A safer wrapper to test-runner-current. | |
227 | (define (test-runner-get) | |
228 | (let ((r (test-runner-current))) | |
229 | (if (not r) | |
230 | (cond-expand | |
231 | (srfi-23 (error "test-runner not initialized - test-begin missing?")) | |
232 | (else #t))) | |
233 | r)) | |
234 | ||
235 | (define (%test-specificier-matches spec runner) | |
236 | (spec runner)) | |
237 | ||
238 | (define (test-runner-create) | |
239 | ((test-runner-factory))) | |
240 | ||
241 | (define (%test-any-specifier-matches list runner) | |
242 | (let ((result #f)) | |
243 | (let loop ((l list)) | |
244 | (cond ((null? l) result) | |
245 | (else | |
246 | (if (%test-specificier-matches (car l) runner) | |
247 | (set! result #t)) | |
248 | (loop (cdr l))))))) | |
249 | ||
250 | ;; Returns #f, #t, or 'xfail. | |
251 | (define (%test-should-execute runner) | |
252 | (let ((run (%test-runner-run-list runner))) | |
253 | (cond ((or | |
254 | (not (or (eqv? run #t) | |
255 | (%test-any-specifier-matches run runner))) | |
256 | (%test-any-specifier-matches | |
257 | (%test-runner-skip-list runner) | |
258 | runner)) | |
259 | (test-result-set! runner 'result-kind 'skip) | |
260 | #f) | |
261 | ((%test-any-specifier-matches | |
262 | (%test-runner-fail-list runner) | |
263 | runner) | |
264 | (test-result-set! runner 'result-kind 'xfail) | |
265 | 'xfail) | |
266 | (else #t)))) | |
267 | ||
268 | (define (%test-begin suite-name count) | |
269 | (if (not (test-runner-current)) | |
270 | (test-runner-current (test-runner-create))) | |
271 | (let ((runner (test-runner-current))) | |
272 | ((test-runner-on-group-begin runner) runner suite-name count) | |
273 | (%test-runner-skip-save! runner | |
274 | (cons (%test-runner-skip-list runner) | |
275 | (%test-runner-skip-save runner))) | |
276 | (%test-runner-fail-save! runner | |
277 | (cons (%test-runner-fail-list runner) | |
278 | (%test-runner-fail-save runner))) | |
279 | (%test-runner-count-list! runner | |
280 | (cons (cons (%test-runner-total-count runner) | |
281 | count) | |
282 | (%test-runner-count-list runner))) | |
283 | (test-runner-group-stack! runner (cons suite-name | |
284 | (test-runner-group-stack runner))))) | |
285 | (cond-expand | |
286 | (kawa | |
287 | ;; Kawa has test-begin built in, implemented as: | |
288 | ;; (begin | |
289 | ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) | |
290 | ;; (%test-begin suite-name [count])) | |
291 | ;; This puts test-begin but only test-begin in the default environment., | |
292 | ;; which makes normal test suites loadable without non-portable commands. | |
293 | ) | |
294 | (else | |
295 | (define-syntax test-begin | |
296 | (syntax-rules () | |
297 | ((test-begin suite-name) | |
298 | (%test-begin suite-name #f)) | |
299 | ((test-begin suite-name count) | |
300 | (%test-begin suite-name count)))))) | |
301 | ||
302 | (define (test-on-group-begin-simple runner suite-name count) | |
303 | (if (null? (test-runner-group-stack runner)) | |
304 | (begin | |
305 | (display "%%%% Starting test ") | |
306 | (display suite-name) | |
307 | (if test-log-to-file | |
308 | (let* ((log-file-name | |
309 | (if (string? test-log-to-file) test-log-to-file | |
310 | (string-append suite-name ".log"))) | |
311 | (log-file | |
312 | (cond-expand (mzscheme | |
313 | (open-output-file log-file-name 'truncate/replace)) | |
314 | (guile-2 | |
315 | (with-fluids ((%default-port-encoding | |
316 | "UTF-8")) | |
c5a855c4 LC |
317 | (let ((p (open-output-file log-file-name))) |
318 | (setvbuf p _IOLBF) | |
319 | p))) | |
341c6fdd LC |
320 | (else (open-output-file log-file-name))))) |
321 | (display "%%%% Starting test " log-file) | |
322 | (display suite-name log-file) | |
323 | (newline log-file) | |
324 | (test-runner-aux-value! runner log-file) | |
325 | (display " (Writing full log to \"") | |
326 | (display log-file-name) | |
327 | (display "\")"))) | |
328 | (newline))) | |
329 | (let ((log (test-runner-aux-value runner))) | |
330 | (if (output-port? log) | |
331 | (begin | |
332 | (display "Group begin: " log) | |
333 | (display suite-name log) | |
334 | (newline log)))) | |
335 | #f) | |
336 | ||
337 | (define (test-on-group-end-simple runner) | |
338 | (let ((log (test-runner-aux-value runner))) | |
339 | (if (output-port? log) | |
340 | (begin | |
341 | (display "Group end: " log) | |
342 | (display (car (test-runner-group-stack runner)) log) | |
343 | (newline log)))) | |
344 | #f) | |
345 | ||
346 | (define (%test-on-bad-count-write runner count expected-count port) | |
347 | (display "*** Total number of tests was " port) | |
348 | (display count port) | |
349 | (display " but should be " port) | |
350 | (display expected-count port) | |
351 | (display ". ***" port) | |
352 | (newline port) | |
353 | (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) | |
354 | (newline port)) | |
355 | ||
356 | (define (test-on-bad-count-simple runner count expected-count) | |
357 | (%test-on-bad-count-write runner count expected-count (current-output-port)) | |
358 | (let ((log (test-runner-aux-value runner))) | |
359 | (if (output-port? log) | |
360 | (%test-on-bad-count-write runner count expected-count log)))) | |
361 | ||
362 | (define (test-on-bad-end-name-simple runner begin-name end-name) | |
363 | (let ((msg (string-append (%test-format-line runner) "test-end " begin-name | |
364 | " does not match test-begin " end-name))) | |
365 | (cond-expand | |
366 | (srfi-23 (error msg)) | |
367 | (else (display msg) (newline))))) | |
368 | ||
369 | ||
370 | (define (%test-final-report1 value label port) | |
371 | (if (> value 0) | |
372 | (begin | |
373 | (display label port) | |
374 | (display value port) | |
375 | (newline port)))) | |
376 | ||
377 | (define (%test-final-report-simple runner port) | |
378 | (%test-final-report1 (test-runner-pass-count runner) | |
379 | "# of expected passes " port) | |
380 | (%test-final-report1 (test-runner-xfail-count runner) | |
381 | "# of expected failures " port) | |
382 | (%test-final-report1 (test-runner-xpass-count runner) | |
383 | "# of unexpected successes " port) | |
384 | (%test-final-report1 (test-runner-fail-count runner) | |
385 | "# of unexpected failures " port) | |
386 | (%test-final-report1 (test-runner-skip-count runner) | |
387 | "# of skipped tests " port)) | |
388 | ||
389 | (define (test-on-final-simple runner) | |
390 | (%test-final-report-simple runner (current-output-port)) | |
391 | (let ((log (test-runner-aux-value runner))) | |
392 | (if (output-port? log) | |
393 | (%test-final-report-simple runner log)))) | |
394 | ||
395 | (define (%test-format-line runner) | |
396 | (let* ((line-info (test-result-alist runner)) | |
397 | (source-file (assq 'source-file line-info)) | |
398 | (source-line (assq 'source-line line-info)) | |
399 | (file (if source-file (cdr source-file) ""))) | |
400 | (if source-line | |
401 | (string-append file ":" | |
402 | (number->string (cdr source-line)) ": ") | |
403 | ""))) | |
404 | ||
405 | (define (%test-end suite-name line-info) | |
406 | (let* ((r (test-runner-get)) | |
407 | (groups (test-runner-group-stack r)) | |
408 | (line (%test-format-line r))) | |
409 | (test-result-alist! r line-info) | |
410 | (if (null? groups) | |
411 | (let ((msg (string-append line "test-end not in a group"))) | |
412 | (cond-expand | |
413 | (srfi-23 (error msg)) | |
414 | (else (display msg) (newline))))) | |
415 | (if (and suite-name (not (equal? suite-name (car groups)))) | |
416 | ((test-runner-on-bad-end-name r) r suite-name (car groups))) | |
417 | (let* ((count-list (%test-runner-count-list r)) | |
418 | (expected-count (cdar count-list)) | |
419 | (saved-count (caar count-list)) | |
420 | (group-count (- (%test-runner-total-count r) saved-count))) | |
421 | (if (and expected-count | |
422 | (not (= expected-count group-count))) | |
423 | ((test-runner-on-bad-count r) r group-count expected-count)) | |
424 | ((test-runner-on-group-end r) r) | |
425 | (test-runner-group-stack! r (cdr (test-runner-group-stack r))) | |
426 | (%test-runner-skip-list! r (car (%test-runner-skip-save r))) | |
427 | (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) | |
428 | (%test-runner-fail-list! r (car (%test-runner-fail-save r))) | |
429 | (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) | |
430 | (%test-runner-count-list! r (cdr count-list)) | |
431 | (if (null? (test-runner-group-stack r)) | |
432 | ((test-runner-on-final r) r))))) | |
433 | ||
434 | (define-syntax test-group | |
435 | (syntax-rules () | |
436 | ((test-group suite-name . body) | |
437 | (let ((r (test-runner-current))) | |
438 | ;; Ideally should also set line-number, if available. | |
439 | (test-result-alist! r (list (cons 'test-name suite-name))) | |
440 | (if (%test-should-execute r) | |
441 | (dynamic-wind | |
442 | (lambda () (test-begin suite-name)) | |
443 | (lambda () . body) | |
444 | (lambda () (test-end suite-name)))))))) | |
445 | ||
446 | (define-syntax test-group-with-cleanup | |
447 | (syntax-rules () | |
448 | ((test-group-with-cleanup suite-name form cleanup-form) | |
449 | (test-group suite-name | |
450 | (dynamic-wind | |
451 | (lambda () #f) | |
452 | (lambda () form) | |
453 | (lambda () cleanup-form)))) | |
454 | ((test-group-with-cleanup suite-name cleanup-form) | |
455 | (test-group-with-cleanup suite-name #f cleanup-form)) | |
456 | ((test-group-with-cleanup suite-name form1 form2 form3 . rest) | |
457 | (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) | |
458 | ||
459 | (define (test-on-test-begin-simple runner) | |
460 | (let ((log (test-runner-aux-value runner))) | |
461 | (if (output-port? log) | |
462 | (let* ((results (test-result-alist runner)) | |
463 | (source-file (assq 'source-file results)) | |
464 | (source-line (assq 'source-line results)) | |
465 | (source-form (assq 'source-form results)) | |
466 | (test-name (assq 'test-name results))) | |
467 | (display "Test begin:" log) | |
468 | (newline log) | |
469 | (if test-name (%test-write-result1 test-name log)) | |
470 | (if source-file (%test-write-result1 source-file log)) | |
471 | (if source-line (%test-write-result1 source-line log)) | |
472 | (if source-file (%test-write-result1 source-form log)))))) | |
473 | ||
474 | (define-syntax test-result-ref | |
475 | (syntax-rules () | |
476 | ((test-result-ref runner pname) | |
477 | (test-result-ref runner pname #f)) | |
478 | ((test-result-ref runner pname default) | |
479 | (let ((p (assq pname (test-result-alist runner)))) | |
480 | (if p (cdr p) default))))) | |
481 | ||
482 | (define (test-on-test-end-simple runner) | |
483 | (let ((log (test-runner-aux-value runner)) | |
484 | (kind (test-result-ref runner 'result-kind))) | |
485 | (if (memq kind '(fail xpass)) | |
486 | (let* ((results (test-result-alist runner)) | |
487 | (source-file (assq 'source-file results)) | |
488 | (source-line (assq 'source-line results)) | |
489 | (test-name (assq 'test-name results))) | |
490 | (if (or source-file source-line) | |
491 | (begin | |
492 | (if source-file (display (cdr source-file))) | |
493 | (display ":") | |
494 | (if source-line (display (cdr source-line))) | |
495 | (display ": "))) | |
496 | (display (if (eq? kind 'xpass) "XPASS" "FAIL")) | |
497 | (if test-name | |
498 | (begin | |
499 | (display " ") | |
500 | (display (cdr test-name)))) | |
501 | (newline))) | |
502 | (if (output-port? log) | |
503 | (begin | |
504 | (display "Test end:" log) | |
505 | (newline log) | |
506 | (let loop ((list (test-result-alist runner))) | |
507 | (if (pair? list) | |
508 | (let ((pair (car list))) | |
509 | ;; Write out properties not written out by on-test-begin. | |
510 | (if (not (memq (car pair) | |
511 | '(test-name source-file source-line source-form))) | |
512 | (%test-write-result1 pair log)) | |
513 | (loop (cdr list))))))))) | |
514 | ||
515 | (define (%test-write-result1 pair port) | |
516 | (display " " port) | |
517 | (display (car pair) port) | |
518 | (display ": " port) | |
519 | (write (cdr pair) port) | |
520 | (newline port)) | |
521 | ||
522 | (define (test-result-set! runner pname value) | |
523 | (let* ((alist (test-result-alist runner)) | |
524 | (p (assq pname alist))) | |
525 | (if p | |
526 | (set-cdr! p value) | |
527 | (test-result-alist! runner (cons (cons pname value) alist))))) | |
528 | ||
529 | (define (test-result-clear runner) | |
530 | (test-result-alist! runner '())) | |
531 | ||
532 | (define (test-result-remove runner pname) | |
533 | (let* ((alist (test-result-alist runner)) | |
534 | (p (assq pname alist))) | |
535 | (if p | |
536 | (test-result-alist! runner | |
537 | (let loop ((r alist)) | |
538 | (if (eq? r p) (cdr r) | |
539 | (cons (car r) (loop (cdr r))))))))) | |
540 | ||
541 | (define (test-result-kind . rest) | |
542 | (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) | |
543 | (test-result-ref runner 'result-kind))) | |
544 | ||
545 | (define (test-passed? . rest) | |
546 | (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) | |
547 | (memq (test-result-ref runner 'result-kind) '(pass xpass)))) | |
548 | ||
549 | (define (%test-report-result) | |
550 | (let* ((r (test-runner-get)) | |
551 | (result-kind (test-result-kind r))) | |
552 | (case result-kind | |
553 | ((pass) | |
554 | (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) | |
555 | ((fail) | |
556 | (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) | |
557 | ((xpass) | |
558 | (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) | |
559 | ((xfail) | |
560 | (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) | |
561 | (else | |
562 | (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) | |
563 | (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) | |
564 | ((test-runner-on-test-end r) r))) | |
565 | ||
566 | (cond-expand | |
567 | (guile | |
568 | (define-syntax %test-evaluate-with-catch | |
569 | (syntax-rules () | |
570 | ((%test-evaluate-with-catch test-expression) | |
571 | (catch #t | |
572 | (lambda () test-expression) | |
573 | (lambda (key . args) #f) | |
574 | (lambda (key . args) | |
575 | (display-backtrace (make-stack #t) (current-error-port)))))))) | |
576 | (kawa | |
577 | (define-syntax %test-evaluate-with-catch | |
578 | (syntax-rules () | |
579 | ((%test-evaluate-with-catch test-expression) | |
580 | (try-catch test-expression | |
581 | (ex <java.lang.Throwable> | |
582 | (test-result-set! (test-runner-current) 'actual-error ex) | |
583 | #f)))))) | |
584 | (srfi-34 | |
585 | (define-syntax %test-evaluate-with-catch | |
586 | (syntax-rules () | |
587 | ((%test-evaluate-with-catch test-expression) | |
588 | (guard (err (else #f)) test-expression))))) | |
589 | (chicken | |
590 | (define-syntax %test-evaluate-with-catch | |
591 | (syntax-rules () | |
592 | ((%test-evaluate-with-catch test-expression) | |
593 | (condition-case test-expression (ex () #f)))))) | |
594 | (else | |
595 | (define-syntax %test-evaluate-with-catch | |
596 | (syntax-rules () | |
597 | ((%test-evaluate-with-catch test-expression) | |
598 | test-expression))))) | |
599 | ||
600 | (cond-expand | |
601 | ((or kawa mzscheme) | |
602 | (cond-expand | |
603 | (mzscheme | |
604 | (define-for-syntax (%test-syntax-file form) | |
605 | (let ((source (syntax-source form))) | |
606 | (cond ((string? source) file) | |
607 | ((path? source) (path->string source)) | |
608 | (else #f))))) | |
609 | (kawa | |
610 | (define (%test-syntax-file form) | |
611 | (syntax-source form)))) | |
612 | (define-for-syntax (%test-source-line2 form) | |
613 | (let* ((line (syntax-line form)) | |
614 | (file (%test-syntax-file form)) | |
615 | (line-pair (if line (list (cons 'source-line line)) '()))) | |
616 | (cons (cons 'source-form (syntax-object->datum form)) | |
617 | (if file (cons (cons 'source-file file) line-pair) line-pair))))) | |
618 | (else | |
619 | (define (%test-source-line2 form) | |
620 | '()))) | |
621 | ||
622 | (define (%test-on-test-begin r) | |
623 | (%test-should-execute r) | |
624 | ((test-runner-on-test-begin r) r) | |
625 | (not (eq? 'skip (test-result-ref r 'result-kind)))) | |
626 | ||
627 | (define (%test-on-test-end r result) | |
628 | (test-result-set! r 'result-kind | |
629 | (if (eq? (test-result-ref r 'result-kind) 'xfail) | |
630 | (if result 'xpass 'xfail) | |
631 | (if result 'pass 'fail)))) | |
632 | ||
633 | (define (test-runner-test-name runner) | |
634 | (test-result-ref runner 'test-name "")) | |
635 | ||
636 | (define-syntax %test-comp2body | |
637 | (syntax-rules () | |
638 | ((%test-comp2body r comp expected expr) | |
639 | (let () | |
640 | (if (%test-on-test-begin r) | |
641 | (let ((exp expected)) | |
642 | (test-result-set! r 'expected-value exp) | |
643 | (let ((res (%test-evaluate-with-catch expr))) | |
644 | (test-result-set! r 'actual-value res) | |
645 | (%test-on-test-end r (comp exp res))))) | |
646 | (%test-report-result))))) | |
647 | ||
648 | (define (%test-approximimate= error) | |
649 | (lambda (value expected) | |
650 | (and (>= value (- expected error)) | |
651 | (<= value (+ expected error))))) | |
652 | ||
653 | (define-syntax %test-comp1body | |
654 | (syntax-rules () | |
655 | ((%test-comp1body r expr) | |
656 | (let () | |
657 | (if (%test-on-test-begin r) | |
658 | (let () | |
659 | (let ((res (%test-evaluate-with-catch expr))) | |
660 | (test-result-set! r 'actual-value res) | |
661 | (%test-on-test-end r res)))) | |
662 | (%test-report-result))))) | |
663 | ||
664 | (cond-expand | |
665 | ((or kawa mzscheme) | |
666 | ;; Should be made to work for any Scheme with syntax-case | |
667 | ;; However, I haven't gotten the quoting working. FIXME. | |
668 | (define-syntax test-end | |
669 | (lambda (x) | |
670 | (syntax-case (list x (list 'quote (%test-source-line2 x))) () | |
671 | (((mac suite-name) line) | |
672 | (syntax | |
673 | (%test-end suite-name line))) | |
674 | (((mac) line) | |
675 | (syntax | |
676 | (%test-end #f line)))))) | |
677 | (define-syntax test-assert | |
678 | (lambda (x) | |
679 | (syntax-case (list x (list 'quote (%test-source-line2 x))) () | |
680 | (((mac tname expr) line) | |
681 | (syntax | |
682 | (let* ((r (test-runner-get)) | |
683 | (name tname)) | |
684 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
685 | (%test-comp1body r expr)))) | |
686 | (((mac expr) line) | |
687 | (syntax | |
688 | (let* ((r (test-runner-get))) | |
689 | (test-result-alist! r line) | |
690 | (%test-comp1body r expr))))))) | |
691 | (define-for-syntax (%test-comp2 comp x) | |
692 | (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) () | |
693 | (((mac tname expected expr) line comp) | |
694 | (syntax | |
695 | (let* ((r (test-runner-get)) | |
696 | (name tname)) | |
697 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
698 | (%test-comp2body r comp expected expr)))) | |
699 | (((mac expected expr) line comp) | |
700 | (syntax | |
701 | (let* ((r (test-runner-get))) | |
702 | (test-result-alist! r line) | |
703 | (%test-comp2body r comp expected expr)))))) | |
704 | (define-syntax test-eqv | |
705 | (lambda (x) (%test-comp2 (syntax eqv?) x))) | |
706 | (define-syntax test-eq | |
707 | (lambda (x) (%test-comp2 (syntax eq?) x))) | |
708 | (define-syntax test-equal | |
709 | (lambda (x) (%test-comp2 (syntax equal?) x))) | |
710 | (define-syntax test-approximate ;; FIXME - needed for non-Kawa | |
711 | (lambda (x) | |
712 | (syntax-case (list x (list 'quote (%test-source-line2 x))) () | |
713 | (((mac tname expected expr error) line) | |
714 | (syntax | |
715 | (let* ((r (test-runner-get)) | |
716 | (name tname)) | |
717 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
718 | (%test-comp2body r (%test-approximimate= error) expected expr)))) | |
719 | (((mac expected expr error) line) | |
720 | (syntax | |
721 | (let* ((r (test-runner-get))) | |
722 | (test-result-alist! r line) | |
723 | (%test-comp2body r (%test-approximimate= error) expected expr)))))))) | |
724 | (else | |
725 | (define-syntax test-end | |
726 | (syntax-rules () | |
727 | ((test-end) | |
728 | (%test-end #f '())) | |
729 | ((test-end suite-name) | |
730 | (%test-end suite-name '())))) | |
731 | (define-syntax test-assert | |
732 | (syntax-rules () | |
733 | ((test-assert tname test-expression) | |
734 | (let* ((r (test-runner-get)) | |
735 | (name tname)) | |
736 | (test-result-alist! r '((test-name . tname))) | |
737 | (%test-comp1body r test-expression))) | |
738 | ((test-assert test-expression) | |
739 | (let* ((r (test-runner-get))) | |
740 | (test-result-alist! r '()) | |
741 | (%test-comp1body r test-expression))))) | |
742 | (define-syntax %test-comp2 | |
743 | (syntax-rules () | |
744 | ((%test-comp2 comp tname expected expr) | |
745 | (let* ((r (test-runner-get)) | |
746 | (name tname)) | |
747 | (test-result-alist! r (list (cons 'test-name tname))) | |
748 | (%test-comp2body r comp expected expr))) | |
749 | ((%test-comp2 comp expected expr) | |
750 | (let* ((r (test-runner-get))) | |
751 | (test-result-alist! r '()) | |
752 | (%test-comp2body r comp expected expr))))) | |
753 | (define-syntax test-equal | |
754 | (syntax-rules () | |
755 | ((test-equal . rest) | |
756 | (%test-comp2 equal? . rest)))) | |
757 | (define-syntax test-eqv | |
758 | (syntax-rules () | |
759 | ((test-eqv . rest) | |
760 | (%test-comp2 eqv? . rest)))) | |
761 | (define-syntax test-eq | |
762 | (syntax-rules () | |
763 | ((test-eq . rest) | |
764 | (%test-comp2 eq? . rest)))) | |
765 | (define-syntax test-approximate | |
766 | (syntax-rules () | |
767 | ((test-approximate tname expected expr error) | |
768 | (%test-comp2 (%test-approximimate= error) tname expected expr)) | |
769 | ((test-approximate expected expr error) | |
770 | (%test-comp2 (%test-approximimate= error) expected expr)))))) | |
771 | ||
772 | (cond-expand | |
773 | (guile | |
774 | (define-syntax %test-error | |
775 | (syntax-rules () | |
776 | ((%test-error r etype expr) | |
777 | (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t))))))) | |
778 | (mzscheme | |
779 | (define-syntax %test-error | |
780 | (syntax-rules () | |
781 | ((%test-error r etype expr) | |
782 | (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) | |
783 | (let () | |
784 | (test-result-set! r 'actual-value expr) | |
785 | #f))))))) | |
786 | (chicken | |
787 | (define-syntax %test-error | |
788 | (syntax-rules () | |
789 | ((%test-error r etype expr) | |
790 | (%test-comp1body r (condition-case expr (ex () #t))))))) | |
791 | (kawa | |
792 | (define-syntax %test-error | |
793 | (syntax-rules () | |
794 | ((%test-error r etype expr) | |
795 | (let () | |
796 | (if (%test-on-test-begin r) | |
797 | (let ((et etype)) | |
798 | (test-result-set! r 'expected-error et) | |
799 | (%test-on-test-end r | |
800 | (try-catch | |
801 | (let () | |
802 | (test-result-set! r 'actual-value expr) | |
803 | #f) | |
804 | (ex <java.lang.Throwable> | |
805 | (test-result-set! r 'actual-error ex) | |
806 | (cond ((and (instance? et <gnu.bytecode.ClassType>) | |
807 | (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) | |
808 | (instance? ex et)) | |
809 | (else #t))))) | |
810 | (%test-report-result)))))))) | |
811 | ((and srfi-34 srfi-35) | |
812 | (define-syntax %test-error | |
813 | (syntax-rules () | |
814 | ((%test-error r etype expr) | |
815 | (%test-comp1body r (guard (ex ((condition-type? etype) | |
816 | (and (condition? ex) (condition-has-type? ex etype))) | |
817 | ((procedure? etype) | |
818 | (etype ex)) | |
819 | ((equal? type #t) | |
820 | #t) | |
821 | (else #t)) | |
822 | expr)))))) | |
823 | (srfi-34 | |
824 | (define-syntax %test-error | |
825 | (syntax-rules () | |
826 | ((%test-error r etype expr) | |
827 | (%test-comp1body r (guard (ex (else #t)) expr)))))) | |
828 | (else | |
829 | (define-syntax %test-error | |
830 | (syntax-rules () | |
831 | ((%test-error r etype expr) | |
832 | (begin | |
833 | ((test-runner-on-test-begin r) r) | |
834 | (test-result-set! r 'result-kind 'skip) | |
835 | (%test-report-result))))))) | |
836 | ||
837 | (cond-expand | |
838 | ((or kawa mzscheme) | |
839 | ||
840 | (define-syntax test-error | |
841 | (lambda (x) | |
842 | (syntax-case (list x (list 'quote (%test-source-line2 x))) () | |
843 | (((mac tname etype expr) line) | |
844 | (syntax | |
845 | (let* ((r (test-runner-get)) | |
846 | (name tname)) | |
847 | (test-result-alist! r (cons (cons 'test-name tname) line)) | |
848 | (%test-error r etype expr)))) | |
849 | (((mac etype expr) line) | |
850 | (syntax | |
851 | (let* ((r (test-runner-get))) | |
852 | (test-result-alist! r line) | |
853 | (%test-error r etype expr)))) | |
854 | (((mac expr) line) | |
855 | (syntax | |
856 | (let* ((r (test-runner-get))) | |
857 | (test-result-alist! r line) | |
858 | (%test-error r #t expr)))))))) | |
859 | (else | |
860 | (define-syntax test-error | |
861 | (syntax-rules () | |
862 | ((test-error name etype expr) | |
863 | (test-assert name (%test-error etype expr))) | |
864 | ((test-error etype expr) | |
865 | (test-assert (%test-error etype expr))) | |
866 | ((test-error expr) | |
867 | (test-assert (%test-error #t expr))))))) | |
868 | ||
869 | (define (test-apply first . rest) | |
870 | (if (test-runner? first) | |
871 | (test-with-runner first (apply test-apply rest)) | |
872 | (let ((r (test-runner-current))) | |
873 | (if r | |
874 | (let ((run-list (%test-runner-run-list r))) | |
875 | (cond ((null? rest) | |
876 | (%test-runner-run-list! r (reverse! run-list)) | |
877 | (first)) ;; actually apply procedure thunk | |
878 | (else | |
879 | (%test-runner-run-list! | |
880 | r | |
881 | (if (eq? run-list #t) (list first) (cons first run-list))) | |
882 | (apply test-apply rest) | |
883 | (%test-runner-run-list! r run-list)))) | |
884 | (let ((r (test-runner-create))) | |
885 | (test-with-runner r (apply test-apply first rest)) | |
886 | ((test-runner-on-final r) r)))))) | |
887 | ||
888 | (define-syntax test-with-runner | |
889 | (syntax-rules () | |
890 | ((test-with-runner runner form ...) | |
891 | (let ((saved-runner (test-runner-current))) | |
892 | (dynamic-wind | |
893 | (lambda () (test-runner-current runner)) | |
894 | (lambda () form ...) | |
895 | (lambda () (test-runner-current saved-runner))))))) | |
896 | ||
897 | ;;; Predicates | |
898 | ||
899 | (define (%test-match-nth n count) | |
900 | (let ((i 0)) | |
901 | (lambda (runner) | |
902 | (set! i (+ i 1)) | |
903 | (and (>= i n) (< i (+ n count)))))) | |
904 | ||
905 | (define-syntax test-match-nth | |
906 | (syntax-rules () | |
907 | ((test-match-nth n) | |
908 | (test-match-nth n 1)) | |
909 | ((test-match-nth n count) | |
910 | (%test-match-nth n count)))) | |
911 | ||
912 | (define (%test-match-all . pred-list) | |
913 | (lambda (runner) | |
914 | (let ((result #t)) | |
915 | (let loop ((l pred-list)) | |
916 | (if (null? l) | |
917 | result | |
918 | (begin | |
919 | (if (not ((car l) runner)) | |
920 | (set! result #f)) | |
921 | (loop (cdr l)))))))) | |
922 | ||
923 | (define-syntax test-match-all | |
924 | (syntax-rules () | |
925 | ((test-match-all pred ...) | |
926 | (%test-match-all (%test-as-specifier pred) ...)))) | |
927 | ||
928 | (define (%test-match-any . pred-list) | |
929 | (lambda (runner) | |
930 | (let ((result #f)) | |
931 | (let loop ((l pred-list)) | |
932 | (if (null? l) | |
933 | result | |
934 | (begin | |
935 | (if ((car l) runner) | |
936 | (set! result #t)) | |
937 | (loop (cdr l)))))))) | |
938 | ||
939 | (define-syntax test-match-any | |
940 | (syntax-rules () | |
941 | ((test-match-any pred ...) | |
942 | (%test-match-any (%test-as-specifier pred) ...)))) | |
943 | ||
944 | ;; Coerce to a predicate function: | |
945 | (define (%test-as-specifier specifier) | |
946 | (cond ((procedure? specifier) specifier) | |
947 | ((integer? specifier) (test-match-nth 1 specifier)) | |
948 | ((string? specifier) (test-match-name specifier)) | |
949 | (else | |
950 | (error "not a valid test specifier")))) | |
951 | ||
952 | (define-syntax test-skip | |
953 | (syntax-rules () | |
954 | ((test-skip pred ...) | |
955 | (let ((runner (test-runner-get))) | |
956 | (%test-runner-skip-list! runner | |
957 | (cons (test-match-all (%test-as-specifier pred) ...) | |
958 | (%test-runner-skip-list runner))))))) | |
959 | ||
960 | (define-syntax test-expect-fail | |
961 | (syntax-rules () | |
962 | ((test-expect-fail pred ...) | |
963 | (let ((runner (test-runner-get))) | |
964 | (%test-runner-fail-list! runner | |
965 | (cons (test-match-all (%test-as-specifier pred) ...) | |
966 | (%test-runner-fail-list runner))))))) | |
967 | ||
968 | (define (test-match-name name) | |
969 | (lambda (runner) | |
970 | (equal? name (test-runner-test-name runner)))) | |
971 | ||
972 | (define (test-read-eval-string string) | |
973 | (let* ((port (open-input-string string)) | |
974 | (form (read port))) | |
975 | (if (eof-object? (read-char port)) | |
976 | (eval form) | |
977 | (cond-expand | |
978 | (srfi-23 (error "(not at eof)")) | |
979 | (else "error"))))) | |
980 |