| blob | 1ea3bd9a9e1bf945c744e677144001af7b09268d |
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.
23 (cond-expand
24 (chicken
25 (require-extension syntax-case))
26 (guile
27 (use-modules (srfi srfi-9)
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 ))
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))))))
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)
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)) ...)))))))
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 )
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 '()))
173 (define (test-runner-group-path runner)
174 (reverse (test-runner-group-stack runner)))
176 (define (%test-null-callback runner) #f)
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))
190 ;; Not part of the specification. FIXME
191 ;; Controls whether a log file is generated.
192 (define test-log-to-file #t)
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))
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))))))
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))
235 (define (%test-specificier-matches spec runner)
236 (spec runner))
238 (define (test-runner-create)
239 ((test-runner-factory)))
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)))))))
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))))
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))))))
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"))
317 (open-output-file log-file-name)))
318 (else (open-output-file log-file-name)))))
319 (display "%%%% Starting test " log-file)
320 (display suite-name log-file)
321 (newline log-file)
322 (test-runner-aux-value! runner log-file)
323 (display " (Writing full log to \"")
324 (display log-file-name)
325 (display "\")")))
326 (newline)))
327 (let ((log (test-runner-aux-value runner)))
328 (if (output-port? log)
329 (begin
330 (display "Group begin: " log)
331 (display suite-name log)
332 (newline log))))
333 #f)
335 (define (test-on-group-end-simple runner)
336 (let ((log (test-runner-aux-value runner)))
337 (if (output-port? log)
338 (begin
339 (display "Group end: " log)
340 (display (car (test-runner-group-stack runner)) log)
341 (newline log))))
342 #f)
344 (define (%test-on-bad-count-write runner count expected-count port)
345 (display "*** Total number of tests was " port)
346 (display count port)
347 (display " but should be " port)
348 (display expected-count port)
349 (display ". ***" port)
350 (newline port)
351 (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
352 (newline port))
354 (define (test-on-bad-count-simple runner count expected-count)
355 (%test-on-bad-count-write runner count expected-count (current-output-port))
356 (let ((log (test-runner-aux-value runner)))
357 (if (output-port? log)
358 (%test-on-bad-count-write runner count expected-count log))))
360 (define (test-on-bad-end-name-simple runner begin-name end-name)
361 (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
362 " does not match test-begin " end-name)))
363 (cond-expand
364 (srfi-23 (error msg))
365 (else (display msg) (newline)))))
368 (define (%test-final-report1 value label port)
369 (if (> value 0)
370 (begin
371 (display label port)
372 (display value port)
373 (newline port))))
375 (define (%test-final-report-simple runner port)
376 (%test-final-report1 (test-runner-pass-count runner)
377 "# of expected passes " port)
378 (%test-final-report1 (test-runner-xfail-count runner)
379 "# of expected failures " port)
380 (%test-final-report1 (test-runner-xpass-count runner)
381 "# of unexpected successes " port)
382 (%test-final-report1 (test-runner-fail-count runner)
383 "# of unexpected failures " port)
384 (%test-final-report1 (test-runner-skip-count runner)
385 "# of skipped tests " port))
387 (define (test-on-final-simple runner)
388 (%test-final-report-simple runner (current-output-port))
389 (let ((log (test-runner-aux-value runner)))
390 (if (output-port? log)
391 (%test-final-report-simple runner log))))
393 (define (%test-format-line runner)
394 (let* ((line-info (test-result-alist runner))
395 (source-file (assq 'source-file line-info))
396 (source-line (assq 'source-line line-info))
397 (file (if source-file (cdr source-file) "")))
398 (if source-line
399 (string-append file ":"
400 (number->string (cdr source-line)) ": ")
401 "")))
403 (define (%test-end suite-name line-info)
404 (let* ((r (test-runner-get))
405 (groups (test-runner-group-stack r))
406 (line (%test-format-line r)))
407 (test-result-alist! r line-info)
408 (if (null? groups)
409 (let ((msg (string-append line "test-end not in a group")))
410 (cond-expand
411 (srfi-23 (error msg))
412 (else (display msg) (newline)))))
413 (if (and suite-name (not (equal? suite-name (car groups))))
414 ((test-runner-on-bad-end-name r) r suite-name (car groups)))
415 (let* ((count-list (%test-runner-count-list r))
416 (expected-count (cdar count-list))
417 (saved-count (caar count-list))
418 (group-count (- (%test-runner-total-count r) saved-count)))
419 (if (and expected-count
420 (not (= expected-count group-count)))
421 ((test-runner-on-bad-count r) r group-count expected-count))
422 ((test-runner-on-group-end r) r)
423 (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
424 (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
425 (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
426 (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
427 (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
428 (%test-runner-count-list! r (cdr count-list))
429 (if (null? (test-runner-group-stack r))
430 ((test-runner-on-final r) r)))))
432 (define-syntax test-group
433 (syntax-rules ()
434 ((test-group suite-name . body)
435 (let ((r (test-runner-current)))
436 ;; Ideally should also set line-number, if available.
437 (test-result-alist! r (list (cons 'test-name suite-name)))
438 (if (%test-should-execute r)
439 (dynamic-wind
440 (lambda () (test-begin suite-name))
441 (lambda () . body)
442 (lambda () (test-end suite-name))))))))
444 (define-syntax test-group-with-cleanup
445 (syntax-rules ()
446 ((test-group-with-cleanup suite-name form cleanup-form)
447 (test-group suite-name
448 (dynamic-wind
449 (lambda () #f)
450 (lambda () form)
451 (lambda () cleanup-form))))
452 ((test-group-with-cleanup suite-name cleanup-form)
453 (test-group-with-cleanup suite-name #f cleanup-form))
454 ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
455 (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
457 (define (test-on-test-begin-simple runner)
458 (let ((log (test-runner-aux-value runner)))
459 (if (output-port? log)
460 (let* ((results (test-result-alist runner))
461 (source-file (assq 'source-file results))
462 (source-line (assq 'source-line results))
463 (source-form (assq 'source-form results))
464 (test-name (assq 'test-name results)))
465 (display "Test begin:" log)
466 (newline log)
467 (if test-name (%test-write-result1 test-name log))
468 (if source-file (%test-write-result1 source-file log))
469 (if source-line (%test-write-result1 source-line log))
470 (if source-file (%test-write-result1 source-form log))))))
472 (define-syntax test-result-ref
473 (syntax-rules ()
474 ((test-result-ref runner pname)
475 (test-result-ref runner pname #f))
476 ((test-result-ref runner pname default)
477 (let ((p (assq pname (test-result-alist runner))))
478 (if p (cdr p) default)))))
480 (define (test-on-test-end-simple runner)
481 (let ((log (test-runner-aux-value runner))
482 (kind (test-result-ref runner 'result-kind)))
483 (if (memq kind '(fail xpass))
484 (let* ((results (test-result-alist runner))
485 (source-file (assq 'source-file results))
486 (source-line (assq 'source-line results))
487 (test-name (assq 'test-name results)))
488 (if (or source-file source-line)
489 (begin
490 (if source-file (display (cdr source-file)))
491 (display ":")
492 (if source-line (display (cdr source-line)))
493 (display ": ")))
494 (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
495 (if test-name
496 (begin
497 (display " ")
498 (display (cdr test-name))))
499 (newline)))
500 (if (output-port? log)
501 (begin
502 (display "Test end:" log)
503 (newline log)
504 (let loop ((list (test-result-alist runner)))
505 (if (pair? list)
506 (let ((pair (car list)))
507 ;; Write out properties not written out by on-test-begin.
508 (if (not (memq (car pair)
509 '(test-name source-file source-line source-form)))
510 (%test-write-result1 pair log))
511 (loop (cdr list)))))))))
513 (define (%test-write-result1 pair port)
514 (display " " port)
515 (display (car pair) port)
516 (display ": " port)
517 (write (cdr pair) port)
518 (newline port))
520 (define (test-result-set! runner pname value)
521 (let* ((alist (test-result-alist runner))
522 (p (assq pname alist)))
523 (if p
524 (set-cdr! p value)
525 (test-result-alist! runner (cons (cons pname value) alist)))))
527 (define (test-result-clear runner)
528 (test-result-alist! runner '()))
530 (define (test-result-remove runner pname)
531 (let* ((alist (test-result-alist runner))
532 (p (assq pname alist)))
533 (if p
534 (test-result-alist! runner
535 (let loop ((r alist))
536 (if (eq? r p) (cdr r)
537 (cons (car r) (loop (cdr r)))))))))
539 (define (test-result-kind . rest)
540 (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
541 (test-result-ref runner 'result-kind)))
543 (define (test-passed? . rest)
544 (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
545 (memq (test-result-ref runner 'result-kind) '(pass xpass))))
547 (define (%test-report-result)
548 (let* ((r (test-runner-get))
549 (result-kind (test-result-kind r)))
550 (case result-kind
551 ((pass)
552 (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
553 ((fail)
554 (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
555 ((xpass)
556 (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
557 ((xfail)
558 (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
559 (else
560 (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
561 (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
562 ((test-runner-on-test-end r) r)))
564 (cond-expand
565 (guile
566 (define-syntax %test-evaluate-with-catch
567 (syntax-rules ()
568 ((%test-evaluate-with-catch test-expression)
569 (catch #t
570 (lambda () test-expression)
571 (lambda (key . args) #f)
572 (lambda (key . args)
573 (display-backtrace (make-stack #t) (current-error-port))))))))
574 (kawa
575 (define-syntax %test-evaluate-with-catch
576 (syntax-rules ()
577 ((%test-evaluate-with-catch test-expression)
578 (try-catch test-expression
579 (ex <java.lang.Throwable>
580 (test-result-set! (test-runner-current) 'actual-error ex)
581 #f))))))
582 (srfi-34
583 (define-syntax %test-evaluate-with-catch
584 (syntax-rules ()
585 ((%test-evaluate-with-catch test-expression)
586 (guard (err (else #f)) test-expression)))))
587 (chicken
588 (define-syntax %test-evaluate-with-catch
589 (syntax-rules ()
590 ((%test-evaluate-with-catch test-expression)
591 (condition-case test-expression (ex () #f))))))
592 (else
593 (define-syntax %test-evaluate-with-catch
594 (syntax-rules ()
595 ((%test-evaluate-with-catch test-expression)
596 test-expression)))))
598 (cond-expand
599 ((or kawa mzscheme)
600 (cond-expand
601 (mzscheme
602 (define-for-syntax (%test-syntax-file form)
603 (let ((source (syntax-source form)))
604 (cond ((string? source) file)
605 ((path? source) (path->string source))
606 (else #f)))))
607 (kawa
608 (define (%test-syntax-file form)
609 (syntax-source form))))
610 (define-for-syntax (%test-source-line2 form)
611 (let* ((line (syntax-line form))
612 (file (%test-syntax-file form))
613 (line-pair (if line (list (cons 'source-line line)) '())))
614 (cons (cons 'source-form (syntax-object->datum form))
615 (if file (cons (cons 'source-file file) line-pair) line-pair)))))
616 (else
617 (define (%test-source-line2 form)
618 '())))
620 (define (%test-on-test-begin r)
621 (%test-should-execute r)
622 ((test-runner-on-test-begin r) r)
623 (not (eq? 'skip (test-result-ref r 'result-kind))))
625 (define (%test-on-test-end r result)
626 (test-result-set! r 'result-kind
627 (if (eq? (test-result-ref r 'result-kind) 'xfail)
628 (if result 'xpass 'xfail)
629 (if result 'pass 'fail))))
631 (define (test-runner-test-name runner)
632 (test-result-ref runner 'test-name ""))
634 (define-syntax %test-comp2body
635 (syntax-rules ()
636 ((%test-comp2body r comp expected expr)
637 (let ()
638 (if (%test-on-test-begin r)
639 (let ((exp expected))
640 (test-result-set! r 'expected-value exp)
641 (let ((res (%test-evaluate-with-catch expr)))
642 (test-result-set! r 'actual-value res)
643 (%test-on-test-end r (comp exp res)))))
644 (%test-report-result)))))
646 (define (%test-approximimate= error)
647 (lambda (value expected)
648 (and (>= value (- expected error))
649 (<= value (+ expected error)))))
651 (define-syntax %test-comp1body
652 (syntax-rules ()
653 ((%test-comp1body r expr)
654 (let ()
655 (if (%test-on-test-begin r)
656 (let ()
657 (let ((res (%test-evaluate-with-catch expr)))
658 (test-result-set! r 'actual-value res)
659 (%test-on-test-end r res))))
660 (%test-report-result)))))
662 (cond-expand
663 ((or kawa mzscheme)
664 ;; Should be made to work for any Scheme with syntax-case
665 ;; However, I haven't gotten the quoting working. FIXME.
666 (define-syntax test-end
667 (lambda (x)
668 (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
669 (((mac suite-name) line)
670 (syntax
671 (%test-end suite-name line)))
672 (((mac) line)
673 (syntax
674 (%test-end #f line))))))
675 (define-syntax test-assert
676 (lambda (x)
677 (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
678 (((mac tname expr) line)
679 (syntax
680 (let* ((r (test-runner-get))
681 (name tname))
682 (test-result-alist! r (cons (cons 'test-name tname) line))
683 (%test-comp1body r expr))))
684 (((mac expr) line)
685 (syntax
686 (let* ((r (test-runner-get)))
687 (test-result-alist! r line)
688 (%test-comp1body r expr)))))))
689 (define-for-syntax (%test-comp2 comp x)
690 (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) ()
691 (((mac tname expected expr) line comp)
692 (syntax
693 (let* ((r (test-runner-get))
694 (name tname))
695 (test-result-alist! r (cons (cons 'test-name tname) line))
696 (%test-comp2body r comp expected expr))))
697 (((mac expected expr) line comp)
698 (syntax
699 (let* ((r (test-runner-get)))
700 (test-result-alist! r line)
701 (%test-comp2body r comp expected expr))))))
702 (define-syntax test-eqv
703 (lambda (x) (%test-comp2 (syntax eqv?) x)))
704 (define-syntax test-eq
705 (lambda (x) (%test-comp2 (syntax eq?) x)))
706 (define-syntax test-equal
707 (lambda (x) (%test-comp2 (syntax equal?) x)))
708 (define-syntax test-approximate ;; FIXME - needed for non-Kawa
709 (lambda (x)
710 (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
711 (((mac tname expected expr error) line)
712 (syntax
713 (let* ((r (test-runner-get))
714 (name tname))
715 (test-result-alist! r (cons (cons 'test-name tname) line))
716 (%test-comp2body r (%test-approximimate= error) expected expr))))
717 (((mac expected expr error) line)
718 (syntax
719 (let* ((r (test-runner-get)))
720 (test-result-alist! r line)
721 (%test-comp2body r (%test-approximimate= error) expected expr))))))))
722 (else
723 (define-syntax test-end
724 (syntax-rules ()
725 ((test-end)
726 (%test-end #f '()))
727 ((test-end suite-name)
728 (%test-end suite-name '()))))
729 (define-syntax test-assert
730 (syntax-rules ()
731 ((test-assert tname test-expression)
732 (let* ((r (test-runner-get))
733 (name tname))
734 (test-result-alist! r '((test-name . tname)))
735 (%test-comp1body r test-expression)))
736 ((test-assert test-expression)
737 (let* ((r (test-runner-get)))
738 (test-result-alist! r '())
739 (%test-comp1body r test-expression)))))
740 (define-syntax %test-comp2
741 (syntax-rules ()
742 ((%test-comp2 comp tname expected expr)
743 (let* ((r (test-runner-get))
744 (name tname))
745 (test-result-alist! r (list (cons 'test-name tname)))
746 (%test-comp2body r comp expected expr)))
747 ((%test-comp2 comp expected expr)
748 (let* ((r (test-runner-get)))
749 (test-result-alist! r '())
750 (%test-comp2body r comp expected expr)))))
751 (define-syntax test-equal
752 (syntax-rules ()
753 ((test-equal . rest)
754 (%test-comp2 equal? . rest))))
755 (define-syntax test-eqv
756 (syntax-rules ()
757 ((test-eqv . rest)
758 (%test-comp2 eqv? . rest))))
759 (define-syntax test-eq
760 (syntax-rules ()
761 ((test-eq . rest)
762 (%test-comp2 eq? . rest))))
763 (define-syntax test-approximate
764 (syntax-rules ()
765 ((test-approximate tname expected expr error)
766 (%test-comp2 (%test-approximimate= error) tname expected expr))
767 ((test-approximate expected expr error)
768 (%test-comp2 (%test-approximimate= error) expected expr))))))
770 (cond-expand
771 (guile
772 (define-syntax %test-error
773 (syntax-rules ()
774 ((%test-error r etype expr)
775 (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t)))))))
776 (mzscheme
777 (define-syntax %test-error
778 (syntax-rules ()
779 ((%test-error r etype expr)
780 (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
781 (let ()
782 (test-result-set! r 'actual-value expr)
783 #f)))))))
784 (chicken
785 (define-syntax %test-error
786 (syntax-rules ()
787 ((%test-error r etype expr)
788 (%test-comp1body r (condition-case expr (ex () #t)))))))
789 (kawa
790 (define-syntax %test-error
791 (syntax-rules ()
792 ((%test-error r etype expr)
793 (let ()
794 (if (%test-on-test-begin r)
795 (let ((et etype))
796 (test-result-set! r 'expected-error et)
797 (%test-on-test-end r
798 (try-catch
799 (let ()
800 (test-result-set! r 'actual-value expr)
801 #f)
802 (ex <java.lang.Throwable>
803 (test-result-set! r 'actual-error ex)
804 (cond ((and (instance? et <gnu.bytecode.ClassType>)
805 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
806 (instance? ex et))
807 (else #t)))))
808 (%test-report-result))))))))
809 ((and srfi-34 srfi-35)
810 (define-syntax %test-error
811 (syntax-rules ()
812 ((%test-error r etype expr)
813 (%test-comp1body r (guard (ex ((condition-type? etype)
814 (and (condition? ex) (condition-has-type? ex etype)))
815 ((procedure? etype)
816 (etype ex))
817 ((equal? type #t)
818 #t)
819 (else #t))
820 expr))))))
821 (srfi-34
822 (define-syntax %test-error
823 (syntax-rules ()
824 ((%test-error r etype expr)
825 (%test-comp1body r (guard (ex (else #t)) expr))))))
826 (else
827 (define-syntax %test-error
828 (syntax-rules ()
829 ((%test-error r etype expr)
830 (begin
831 ((test-runner-on-test-begin r) r)
832 (test-result-set! r 'result-kind 'skip)
833 (%test-report-result)))))))
835 (cond-expand
836 ((or kawa mzscheme)
838 (define-syntax test-error
839 (lambda (x)
840 (syntax-case (list x (list 'quote (%test-source-line2 x))) ()
841 (((mac tname etype expr) line)
842 (syntax
843 (let* ((r (test-runner-get))
844 (name tname))
845 (test-result-alist! r (cons (cons 'test-name tname) line))
846 (%test-error r etype expr))))
847 (((mac etype expr) line)
848 (syntax
849 (let* ((r (test-runner-get)))
850 (test-result-alist! r line)
851 (%test-error r etype expr))))
852 (((mac expr) line)
853 (syntax
854 (let* ((r (test-runner-get)))
855 (test-result-alist! r line)
856 (%test-error r #t expr))))))))
857 (else
858 (define-syntax test-error
859 (syntax-rules ()
860 ((test-error name etype expr)
861 (test-assert name (%test-error etype expr)))
862 ((test-error etype expr)
863 (test-assert (%test-error etype expr)))
864 ((test-error expr)
865 (test-assert (%test-error #t expr)))))))
867 (define (test-apply first . rest)
868 (if (test-runner? first)
869 (test-with-runner first (apply test-apply rest))
870 (let ((r (test-runner-current)))
871 (if r
872 (let ((run-list (%test-runner-run-list r)))
873 (cond ((null? rest)
874 (%test-runner-run-list! r (reverse! run-list))
875 (first)) ;; actually apply procedure thunk
876 (else
877 (%test-runner-run-list!
878 r
879 (if (eq? run-list #t) (list first) (cons first run-list)))
880 (apply test-apply rest)
881 (%test-runner-run-list! r run-list))))
882 (let ((r (test-runner-create)))
883 (test-with-runner r (apply test-apply first rest))
884 ((test-runner-on-final r) r))))))
886 (define-syntax test-with-runner
887 (syntax-rules ()
888 ((test-with-runner runner form ...)
889 (let ((saved-runner (test-runner-current)))
890 (dynamic-wind
891 (lambda () (test-runner-current runner))
892 (lambda () form ...)
893 (lambda () (test-runner-current saved-runner)))))))
895 ;;; Predicates
897 (define (%test-match-nth n count)
898 (let ((i 0))
899 (lambda (runner)
900 (set! i (+ i 1))
901 (and (>= i n) (< i (+ n count))))))
903 (define-syntax test-match-nth
904 (syntax-rules ()
905 ((test-match-nth n)
906 (test-match-nth n 1))
907 ((test-match-nth n count)
908 (%test-match-nth n count))))
910 (define (%test-match-all . pred-list)
911 (lambda (runner)
912 (let ((result #t))
913 (let loop ((l pred-list))
914 (if (null? l)
915 result
916 (begin
917 (if (not ((car l) runner))
918 (set! result #f))
919 (loop (cdr l))))))))
921 (define-syntax test-match-all
922 (syntax-rules ()
923 ((test-match-all pred ...)
924 (%test-match-all (%test-as-specifier pred) ...))))
926 (define (%test-match-any . pred-list)
927 (lambda (runner)
928 (let ((result #f))
929 (let loop ((l pred-list))
930 (if (null? l)
931 result
932 (begin
933 (if ((car l) runner)
934 (set! result #t))
935 (loop (cdr l))))))))
937 (define-syntax test-match-any
938 (syntax-rules ()
939 ((test-match-any pred ...)
940 (%test-match-any (%test-as-specifier pred) ...))))
942 ;; Coerce to a predicate function:
943 (define (%test-as-specifier specifier)
944 (cond ((procedure? specifier) specifier)
945 ((integer? specifier) (test-match-nth 1 specifier))
946 ((string? specifier) (test-match-name specifier))
947 (else
948 (error "not a valid test specifier"))))
950 (define-syntax test-skip
951 (syntax-rules ()
952 ((test-skip pred ...)
953 (let ((runner (test-runner-get)))
954 (%test-runner-skip-list! runner
955 (cons (test-match-all (%test-as-specifier pred) ...)
956 (%test-runner-skip-list runner)))))))
958 (define-syntax test-expect-fail
959 (syntax-rules ()
960 ((test-expect-fail pred ...)
961 (let ((runner (test-runner-get)))
962 (%test-runner-fail-list! runner
963 (cons (test-match-all (%test-as-specifier pred) ...)
964 (%test-runner-fail-list runner)))))))
966 (define (test-match-name name)
967 (lambda (runner)
968 (equal? name (test-runner-test-name runner))))
970 (define (test-read-eval-string string)
971 (let* ((port (open-input-string string))
972 (form (read port)))
973 (if (eof-object? (read-char port))
974 (eval form)
975 (cond-expand
976 (srfi-23 (error "(not at eof)"))
977 (else "error")))))