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