HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Merge commit '01a301d1b606b84d986b735049e7155d2f4cd6aa'
[bpt/guile.git] / test-suite / tests / srfi-64-test.scm
CommitLineData
34e89877
MW		 1;;;
2;;; This is a test suite written in the notation of
3;;; SRFI-64, A Scheme API for test suites
4;;;
5
6(test-begin "SRFI 64 - Meta-Test Suite")
7
8;;;
9;;; Ironically, in order to set up the meta-test environment,
10;;; we have to invoke one of the most sophisticated features:
11;;; custom test runners
12;;;
13
14;;; The `prop-runner' invokes `thunk' in the context of a new
15;;; test runner, and returns the indicated properties of the
16;;; last-executed test result.
17
18(define (prop-runner props thunk)
19 (let ((r (test-runner-null))
20 (plist '()))
21 ;;
22 (test-runner-on-test-end!
23 r
24 (lambda (runner)
25 (set! plist (test-result-alist runner))))
26 ;;
27 (test-with-runner r (thunk))
28 ;; reorder the properties so they are in the order
29 ;; given by `props'. Note that any property listed in `props'
30 ;; that is not in the property alist will occur as #f
31 (map (lambda (k)
32 (assq k plist))
33 props)))
34
35;;; `on-test-runner' creates a null test runner and then
36;;; arranged for `visit' to be called with the runner
37;;; whenever a test is run. The results of the calls to
38;;; `visit' are returned in a list
39
40(define (on-test-runner thunk visit)
41 (let ((r (test-runner-null))
42 (results '()))
43 ;;
44 (test-runner-on-test-end!
45 r
46 (lambda (runner)
47 (set! results (cons (visit r) results))))
48 ;;
49 (test-with-runner r (thunk))
50 (reverse results)))
51
52;;;
53;;; The `triv-runner' invokes `thunk'
54;;; and returns a list of 6 lists, the first 5 of which
55;;; are a list of the names of the tests that, respectively,
56;;; PASS, FAIL, XFAIL, XPASS, and SKIP.
57;;; The last item is a list of counts.
58;;;
59
60(define (triv-runner thunk)
61 (let ((r (test-runner-null))
62 (accum-pass '())
63 (accum-fail '())
64 (accum-xfail '())
65 (accum-xpass '())
66 (accum-skip '()))
67 ;;
68 (test-runner-on-bad-count!
69 r
70 (lambda (runner count expected-count)
71 (error (string-append "bad count " (number->string count)
72 " but expected "
73 (number->string expected-count)))))
74 (test-runner-on-bad-end-name!
75 r
76 (lambda (runner begin end)
77 (error (string-append "bad end group name " end
78 " but expected " begin))))
79 (test-runner-on-test-end!
80 r
81 (lambda (runner)
82 (let ((n (test-runner-test-name runner)))
83 (case (test-result-kind runner)
84 ((pass) (set! accum-pass (cons n accum-pass)))
85 ((fail) (set! accum-fail (cons n accum-fail)))
86 ((xpass) (set! accum-xpass (cons n accum-xpass)))
87 ((xfail) (set! accum-xfail (cons n accum-xfail)))
88 ((skip) (set! accum-skip (cons n accum-skip)))))))
89 ;;
90 (test-with-runner r (thunk))
91 (list (reverse accum-pass) ; passed as expected
92 (reverse accum-fail) ; failed, but was expected to pass
93 (reverse accum-xfail) ; failed as expected
94 (reverse accum-xpass) ; passed, but was expected to fail
95 (reverse accum-skip) ; was not executed
96 (list (test-runner-pass-count r)
97 (test-runner-fail-count r)
98 (test-runner-xfail-count r)
99 (test-runner-xpass-count r)
100 (test-runner-skip-count r)))))
101
102(define (path-revealing-runner thunk)
103 (let ((r (test-runner-null))
104 (seq '()))
105 ;;
106 (test-runner-on-test-end!
107 r
108 (lambda (runner)
109 (set! seq (cons (list (test-runner-group-path runner)
110 (test-runner-test-name runner))
111 seq))))
112 (test-with-runner r (thunk))
113 (reverse seq)))
114
115;;;
116;;; Now we can start testing compliance with SRFI-64
117;;;
118
119(test-begin "1. Simple test-cases")
120
121(test-begin "1.1. test-assert")
122
123(define (t)
124 (triv-runner
125 (lambda ()
126 (test-assert "a" #t)
127 (test-assert "b" #f))))
128
129(test-equal
130 "1.1.1. Very simple"
131 '(("a") ("b") () () () (1 1 0 0 0))
132 (t))
133
134(test-equal
135 "1.1.2. A test with no name"
136 '(("a") ("") () () () (1 1 0 0 0))
137 (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
138
139(test-equal
140 "1.1.3. Tests can have the same name"
141 '(("a" "a") () () () () (2 0 0 0 0))
142 (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
143
144(define (choke)
145 (vector-ref '#(1 2) 3))
146
147(test-equal
148 "1.1.4. One way to FAIL is to throw an error"
149 '(() ("a") () () () (0 1 0 0 0))
150 (triv-runner (lambda () (test-assert "a" (choke)))))
151
152(test-end);1.1
153
154(test-begin "1.2. test-eqv")
155
156(define (mean x y)
157 (/ (+ x y) 2.0))
158
159(test-equal
160 "1.2.1. Simple numerical equivalence"
161 '(("c") ("a" "b") () () () (1 2 0 0 0))
162 (triv-runner
163 (lambda ()
164 (test-eqv "a" (mean 3 5) 4)
165 (test-eqv "b" (mean 3 5) 4.5)
166 (test-eqv "c" (mean 3 5) 4.0))))
167
168(test-end);1.2
169
170(test-end "1. Simple test-cases")
171
172;;;
173;;;
174;;;
175
176(test-begin "2. Tests for catching errors")
177
178(test-begin "2.1. test-error")
179
180(test-equal
181 "2.1.1. Baseline test; PASS with no optional args"
182 '(("") () () () () (1 0 0 0 0))
183 (triv-runner
184 (lambda ()
185 ;; PASS
186 (test-error (vector-ref '#(1 2) 9)))))
187
188(test-equal
189 "2.1.2. Baseline test; FAIL with no optional args"
190 '(() ("") () () () (0 1 0 0 0))
191 (triv-runner
192 (lambda ()
193 ;; FAIL: the expr does not raise an error and `test-error' is
194 ;; claiming that it will, so this test should FAIL
195 (test-error (vector-ref '#(1 2) 0)))))
196
197(test-equal
198 "2.1.3. PASS with a test name and error type"
199 '(("a") () () () () (1 0 0 0 0))
200 (triv-runner
201 (lambda ()
202 ;; PASS
203 (test-error "a" #t (vector-ref '#(1 2) 9)))))
204
205(test-end "2.1. test-error")
206
207(test-end "2. Tests for catching errors")
208
209;;;
210;;;
211;;;
212
213(test-begin "3. Test groups and paths")
214
215(test-equal
216 "3.1. test-begin with unspecific test-end"
217 '(("b") () () () () (1 0 0 0 0))
218 (triv-runner
219 (lambda ()
220 (test-begin "a")
221 (test-assert "b" #t)
222 (test-end))))
223
224(test-equal
225 "3.2. test-begin with name-matching test-end"
226 '(("b") () () () () (1 0 0 0 0))
227 (triv-runner
228 (lambda ()
229 (test-begin "a")
230 (test-assert "b" #t)
231 (test-end "a"))))
232
233;;; since the error raised by `test-end' on a mismatch is not a test
234;;; error, we actually expect the triv-runner itself to fail
235
236(test-error
237 "3.3. test-begin with mismatched test-end"
238#t
239 (triv-runner
240 (lambda ()
241 (test-begin "a")
242 (test-assert "b" #t)
243 (test-end "x"))))
244
245(test-equal
246 "3.4. test-begin with name and count"
247 '(("b" "c") () () () () (2 0 0 0 0))
248 (triv-runner
249 (lambda ()
250 (test-begin "a" 2)
251 (test-assert "b" #t)
252 (test-assert "c" #t)
253 (test-end "a"))))
254
255;; similarly here, a mismatched count is a lexical error
256;; and not a test failure...
257
258(test-error
259 "3.5. test-begin with mismatched count"
260 #t
261 (triv-runner
262 (lambda ()
263 (test-begin "a" 99)
264 (test-assert "b" #t)
265 (test-end "a"))))
266
267(test-equal
268 "3.6. introspecting on the group path"
269 '((() "w")
270 (("a" "b") "x")
271 (("a" "b") "y")
272 (("a") "z"))
273 ;;
274 ;; `path-revealing-runner' is designed to return a list
275 ;; of the tests executed, in order. Each entry is a list
276 ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
277 ;; of test groups starting from the topmost
278 ;;
279 (path-revealing-runner
280 (lambda ()
281 (test-assert "w" #t)
282 (test-begin "a")
283 (test-begin "b")
284 (test-assert "x" #t)
285 (test-assert "y" #t)
286 (test-end)
287 (test-assert "z" #t))))
288
289
290(test-end "3. Test groups and paths")
291
292;;;
293;;;
294;;;
295
296(test-begin "4. Handling set-up and cleanup")
297
298(test-equal "4.1. Normal exit path"
299 '(in 1 2 out)
300 (let ((ex '()))
301 (define (do s)
302 (set! ex (cons s ex)))
303 ;;
304 (triv-runner
305 (lambda ()
306 (test-group-with-cleanup
307 "foo"
308 (do 'in)
309 (do 1)
310 (do 2)
311 (do 'out))))
312 (reverse ex)))
313
314(test-equal "4.2. Exception exit path"
315 '(in 1 out)
316 (let ((ex '()))
317 (define (do s)
318 (set! ex (cons s ex)))
319 ;;
320 ;; the outer runner is to run the `test-error' in, to
321 ;; catch the exception raised in the inner runner,
322 ;; since we don't want to depend on any other
323 ;; exception-catching support
324 ;;
325 (triv-runner
326 (lambda ()
327 (test-error
328 (triv-runner
329 (lambda ()
330 (test-group-with-cleanup
331 "foo"
332 (do 'in) (test-assert #t)
333 (do 1) (test-assert #t)
334 (choke) (test-assert #t)
335 (do 2) (test-assert #t)
336 (do 'out)))))))
337 (reverse ex)))
338
339(test-end "4. Handling set-up and cleanup")
340
341;;;
342;;;
343;;;
344
345(test-begin "5. Test specifiers")
346
347(test-begin "5.1. test-match-named")
348
349(test-equal "5.1.1. match test names"
350 '(("y") () () () ("x") (1 0 0 0 1))
351 (triv-runner
352 (lambda ()
353 (test-skip (test-match-name "x"))
354 (test-assert "x" #t)
355 (test-assert "y" #t))))
356
357(test-equal "5.1.2. but not group names"
358 '(("z") () () () () (1 0 0 0 0))
359 (triv-runner
360 (lambda ()
361 (test-skip (test-match-name "x"))
362 (test-begin "x")
363 (test-assert "z" #t)
364 (test-end))))
365
366(test-end)
367
368(test-begin "5.2. test-match-nth")
369;; See also: [6.4. Short-circuit evaluation]
370
371(test-equal "5.2.1. skip the nth one after"
372 '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
373 (triv-runner
374 (lambda ()
375 (test-assert "v" #t)
376 (test-skip (test-match-nth 2))
377 (test-assert "w" #t) ; 1
378 (test-assert "x" #t) ; 2 SKIP
379 (test-assert "y" #t) ; 3
380 (test-assert "z" #t)))) ; 4
381
382(test-equal "5.2.2. skip m, starting at n"
383 '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
384 (triv-runner
385 (lambda ()
386 (test-assert "v" #t)
387 (test-skip (test-match-nth 2 2))
388 (test-assert "w" #t) ; 1
389 (test-assert "x" #t) ; 2 SKIP
390 (test-assert "y" #t) ; 3 SKIP
391 (test-assert "z" #t)))) ; 4
392
393(test-end)
394
395(test-begin "5.3. test-match-any")
396(test-equal "5.3.1. basic disjunction"
397 '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
398 (triv-runner
399 (lambda ()
400 (test-assert "v" #t)
401 (test-skip (test-match-any (test-match-nth 3)
402 (test-match-name "x")))
403 (test-assert "w" #t) ; 1
404 (test-assert "x" #t) ; 2 SKIP(NAME)
405 (test-assert "y" #t) ; 3 SKIP(COUNT)
406 (test-assert "z" #t)))) ; 4
407
408(test-equal "5.3.2. disjunction is commutative"
409 '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
410 (triv-runner
411 (lambda ()
412 (test-assert "v" #t)
413 (test-skip (test-match-any (test-match-name "x")
414 (test-match-nth 3)))
415 (test-assert "w" #t) ; 1
416 (test-assert "x" #t) ; 2 SKIP(NAME)
417 (test-assert "y" #t) ; 3 SKIP(COUNT)
418 (test-assert "z" #t)))) ; 4
419
420(test-end)
421
422(test-begin "5.4. test-match-all")
423(test-equal "5.4.1. basic conjunction"
424 '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
425 (triv-runner
426 (lambda ()
427 (test-assert "v" #t)
428 (test-skip (test-match-all (test-match-nth 2 2)
429 (test-match-name "x")))
430 (test-assert "w" #t) ; 1
431 (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
432 (test-assert "y" #t) ; 3 SKIP(COUNT)
433 (test-assert "z" #t)))) ; 4
434
435(test-equal "5.4.2. conjunction is commutative"
436 '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
437 (triv-runner
438 (lambda ()
439 (test-assert "v" #t)
440 (test-skip (test-match-all (test-match-name "x")
441 (test-match-nth 2 2)))
442 (test-assert "w" #t) ; 1
443 (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
444 (test-assert "y" #t) ; 3 SKIP(COUNT)
445 (test-assert "z" #t)))) ; 4
446
447(test-end)
448
449(test-end "5. Test specifiers")
450
451;;;
452;;;
453;;;
454
455(test-begin "6. Skipping selected tests")
456
457(test-equal
458 "6.1. Skip by specifier - match-name"
459 '(("x") () () () ("y") (1 0 0 0 1))
460 (triv-runner
461 (lambda ()
462 (test-begin "a")
463 (test-skip (test-match-name "y"))
464 (test-assert "x" #t) ; PASS
465 (test-assert "y" #f) ; SKIP
466 (test-end))))
467
468(test-equal
469 "6.2. Shorthand specifiers"
470 '(("x") () () () ("y") (1 0 0 0 1))
471 (triv-runner
472 (lambda ()
473 (test-begin "a")
474 (test-skip "y")
475 (test-assert "x" #t) ; PASS
476 (test-assert "y" #f) ; SKIP
477 (test-end))))
478
479(test-begin "6.3. Specifier Stack")
480
481(test-equal
482 "6.3.1. Clearing the Specifier Stack"
483 '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
484 (triv-runner
485 (lambda ()
486 (test-begin "a")
487 (test-skip "y")
488 (test-assert "x" #t) ; PASS
489 (test-assert "y" #f) ; SKIP
490 (test-end)
491 (test-begin "b")
492 (test-assert "x" #t) ; PASS
493 (test-assert "y" #f) ; FAIL
494 (test-end))))
495
496(test-equal
497 "6.3.2. Inheriting the Specifier Stack"
498 '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
499 (triv-runner
500 (lambda ()
501 (test-skip "y")
502 (test-begin "a")
503 (test-assert "x" #t) ; PASS
504 (test-assert "y" #f) ; SKIP
505 (test-end)
506 (test-begin "b")
507 (test-assert "x" #t) ; PASS
508 (test-assert "y" #f) ; SKIP
509 (test-end))))
510
511(test-end);6.3
512
513(test-begin "6.4. Short-circuit evaluation")
514
515(test-equal
516 "6.4.1. In test-match-all"
517 '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
518 (triv-runner
519 (lambda ()
520 (test-begin "a")
521 (test-skip (test-match-all "y" (test-match-nth 2)))
522 ;; let's label the substructure forms so we can
523 ;; see which one `test-match-nth' is going to skip
524 ;; ; # "y" 2 result
525 (test-assert "x" #t) ; 1 - #f #f PASS
526 (test-assert "y" #f) ; 2 - #t #t SKIP
527 (test-assert "y" #f) ; 3 - #t #f FAIL
528 (test-assert "x" #f) ; 4 - #f #f FAIL
529 (test-assert "z" #f) ; 5 - #f #f FAIL
530 (test-end))))
531
532(test-equal
533 "6.4.2. In separate skip-list entries"
534 '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
535 (triv-runner
536 (lambda ()
537 (test-begin "a")
538 (test-skip "y")
539 (test-skip (test-match-nth 2))
540 ;; let's label the substructure forms so we can
541 ;; see which one `test-match-nth' is going to skip
542 ;; ; # "y" 2 result
543 (test-assert "x" #t) ; 1 - #f #f PASS
544 (test-assert "y" #f) ; 2 - #t #t SKIP
545 (test-assert "y" #f) ; 3 - #t #f SKIP
546 (test-assert "x" #f) ; 4 - #f #f FAIL
547 (test-assert "z" #f) ; 5 - #f #f FAIL
548 (test-end))))
549
550(test-begin "6.4.3. Skipping test suites")
551
552(test-equal
553 "6.4.3.1. Introduced using 'test-begin'"
554 '(("x") () () () () (1 0 0 0 0))
555 (triv-runner
556 (lambda ()
557 (test-begin "a")
558 (test-skip "b")
559 (test-begin "b") ; not skipped
560 (test-assert "x" #t)
561 (test-end "b")
562 (test-end "a"))))
563
564(test-expect-fail 1) ;; ???
565(test-equal
566 "6.4.3.2. Introduced using 'test-group'"
567 '(() () () () () (0 0 0 0 1))
568 (triv-runner
569 (lambda ()
570 (test-begin "a")
571 (test-skip "b")
572 (test-group
573 "b" ; skipped
574 (test-assert "x" #t))
575 (test-end "a"))))
576
577(test-equal
578 "6.4.3.3. Non-skipped 'test-group'"
579 '(("x") () () () () (1 0 0 0 0))
580 (triv-runner
581 (lambda ()
582 (test-begin "a")
583 (test-skip "c")
584 (test-group "b" (test-assert "x" #t))
585 (test-end "a"))))
586
587(test-end) ; 6.4.3
588
589(test-end);6.4
590
591(test-end "6. Skipping selected tests")
592
593;;;
594;;;
595;;;
596
597(test-begin "7. Expected failures")
598
599(test-equal "7.1. Simple example"
600 '(() ("x") ("z") () () (0 1 1 0 0))
601 (triv-runner
602 (lambda ()
603 (test-assert "x" #f)
604 (test-expect-fail "z")
605 (test-assert "z" #f))))
606
607(test-equal "7.2. Expected exception"
608 '(() ("x") ("z") () () (0 1 1 0 0))
609 (triv-runner
610 (lambda ()
611 (test-assert "x" #f)
612 (test-expect-fail "z")
613 (test-assert "z" (choke)))))
614
615(test-equal "7.3. Unexpectedly PASS"
616 '(() () ("y") ("x") () (0 0 1 1 0))
617 (triv-runner
618 (lambda ()
619 (test-expect-fail "x")
620 (test-expect-fail "y")
621 (test-assert "x" #t)
622 (test-assert "y" #f))))
623
624
625
626(test-end "7. Expected failures")
627
628;;;
629;;;
630;;;
631
632(test-begin "8. Test-runner")
633
634;;;
635;;; Because we want this test suite to be accurate even
636;;; when the underlying implementation chooses to use, e.g.,
637;;; a global variable to implement what could be thread variables
638;;; or SRFI-39 parameter objects, we really need to save and restore
639;;; their state ourselves
640;;;
641(define (with-factory-saved thunk)
642 (let* ((saved (test-runner-factory))
643 (result (thunk)))
644 (test-runner-factory saved)
645 result))
646
647(test-begin "8.1. test-runner-current")
648(test-assert "8.1.1. automatically restored"
649 (let ((a 0)
650 (b 1)
651 (c 2))
652 ;
653 (triv-runner
654 (lambda ()
655 (set! a (test-runner-current))
656 ;;
657 (triv-runner
658 (lambda ()
659 (set! b (test-runner-current))))
660 ;;
661 (set! c (test-runner-current))))
662 ;;
663 (and (eq? a c)
664 (not (eq? a b)))))
665
666(test-end)
667
668(test-begin "8.2. test-runner-simple")
669(test-assert "8.2.1. default on-test hook"
670 (eq? (test-runner-on-test-end (test-runner-simple))
671 test-on-test-end-simple))
672(test-assert "8.2.2. default on-final hook"
673 (eq? (test-runner-on-final (test-runner-simple))
674 test-on-final-simple))
675(test-end)
676
677(test-begin "8.3. test-runner-factory")
678
679(test-assert "8.3.1. default factory"
680 (eq? (test-runner-factory) test-runner-simple))
681
682(test-assert "8.3.2. settable factory"
683 (with-factory-saved
684 (lambda ()
685 (test-runner-factory test-runner-null)
686 ;; we have no way, without bringing in other SRFIs,
687 ;; to make sure the following doesn't print anything,
688 ;; but it shouldn't:
689 (test-with-runner
690 (test-runner-create)
691 (lambda ()
692 (test-begin "a")
693 (test-assert #t) ; pass
694 (test-assert #f) ; fail
695 (test-assert (vector-ref '#(3) 10)) ; fail with error
696 (test-end "a")))
697 (eq? (test-runner-factory) test-runner-null))))
698
699(test-end)
700
701;;; This got tested about as well as it could in 8.3.2
702
703(test-begin "8.4. test-runner-create")
704(test-end)
705
706;;; This got tested about as well as it could in 8.3.2
707
708(test-begin "8.5. test-runner-factory")
709(test-end)
710
711(test-begin "8.6. test-apply")
712(test-equal "8.6.1. Simple (form 1) test-apply"
713 '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
714 (triv-runner
715 (lambda ()
716 (test-begin "a")
717 (test-assert "w" #t)
718 (test-apply
719 (test-match-name "p")
720 (lambda ()
721 (test-begin "p")
722 (test-assert "x" #t)
723 (test-end)
724 (test-begin "z")
725 (test-assert "p" #t) ; only this one should execute in here
726 (test-end)))
727 (test-assert "v" #t))))
728
729(test-equal "8.6.2. Simple (form 2) test-apply"
730 '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
731 (triv-runner
732 (lambda ()
733 (test-begin "a")
734 (test-assert "w" #t)
735 (test-apply
736 (test-runner-current)
737 (test-match-name "p")
738 (lambda ()
739 (test-begin "p")
740 (test-assert "x" #t)
741 (test-end)
742 (test-begin "z")
743 (test-assert "p" #t) ; only this one should execute in here
744 (test-end)))
745 (test-assert "v" #t))))
746
747(test-expect-fail 1) ;; depends on all test-match-nth being called.
748(test-equal "8.6.3. test-apply with skips"
749 '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
750 (triv-runner
751 (lambda ()
752 (test-begin "a")
753 (test-assert "w" #t)
754 (test-skip (test-match-nth 2))
755 (test-skip (test-match-nth 4))
756 (test-apply
757 (test-runner-current)
758 (test-match-name "p")
759 (test-match-name "q")
760 (lambda ()
761 ; only execute if SKIP=no and APPLY=yes
762 (test-assert "x" #t) ; # 1 SKIP=no APPLY=no
763 (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes
764 (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes
765 (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no
766 0))
767 (test-assert "v" #t))))
768
769;;; Unfortunately, since there is no way to UNBIND the current test runner,
770;;; there is no way to test the behavior of `test-apply' in the absence
771;;; of a current runner within our little meta-test framework.
772;;;
773;;; To test the behavior manually, you should be able to invoke:
774;;;
775;;; (test-apply "a" (lambda () (test-assert "a" #t)))
776;;;
777;;; from the top level (with SRFI 64 available) and it should create a
778;;; new, default (simple) test runner.
779
780(test-end)
781
782;;; This entire suite depends heavily on 'test-with-runner'. If it didn't
783;;; work, this suite would probably go down in flames
784(test-begin "8.7. test-with-runner")
785(test-end)
786
787;;; Again, this suite depends heavily on many of the test-runner
788;;; components. We'll just test those that aren't being exercised
789;;; by the meta-test framework
790(test-begin "8.8. test-runner components")
791
792(define (auxtrack-runner thunk)
793 (let ((r (test-runner-null)))
794 (test-runner-aux-value! r '())
795 (test-runner-on-test-end! r (lambda (r)
796 (test-runner-aux-value!
797 r
798 (cons (test-runner-test-name r)
799 (test-runner-aux-value r)))))
800 (test-with-runner r (thunk))
801 (reverse (test-runner-aux-value r))))
802
803(test-equal "8.8.1. test-runner-aux-value"
804 '("x" "" "y")
805 (auxtrack-runner
806 (lambda ()
807 (test-assert "x" #t)
808 (test-begin "a")
809 (test-assert #t)
810 (test-end)
811 (test-assert "y" #f))))
812
813(test-end) ; 8.8
814
815(test-end "8. Test-runner")
816
817(test-begin "9. Test Result Properties")
818
819(test-begin "9.1. test-result-alist")
820
821(define (symbol-alist? l)
822 (if (null? l)
823 #t
824 (and (pair? l)
825 (pair? (car l))
826 (symbol? (caar l))
827 (symbol-alist? (cdr l)))))
828
829;;; check the various syntactic forms
830
831(test-assert (symbol-alist?
832 (car (on-test-runner
833 (lambda ()
834 (test-assert #t))
835 (lambda (r)
836 (test-result-alist r))))))
837
838(test-assert (symbol-alist?
839 (car (on-test-runner
840 (lambda ()
841 (test-assert #t))
842 (lambda (r)
843 (test-result-alist r))))))
844
845;;; check to make sure the required properties are returned
846
847(test-equal '((result-kind . pass))
848 (prop-runner
849 '(result-kind)
850 (lambda ()
851 (test-assert #t)))
852 )
853
854(test-equal
855 '((result-kind . fail)
856 (expected-value . 2)
857 (actual-value . 3))
858 (prop-runner
859 '(result-kind expected-value actual-value)
860 (lambda ()
861 (test-equal 2 (+ 1 2)))))
862
863(test-end "9.1. test-result-alist")
864
865(test-begin "9.2. test-result-ref")
866
867(test-equal '(pass)
868 (on-test-runner
869 (lambda ()
870 (test-assert #t))
871 (lambda (r)
872 (test-result-ref r 'result-kind))))
873
874(test-equal '(pass)
875 (on-test-runner
876 (lambda ()
877 (test-assert #t))
878 (lambda (r)
879 (test-result-ref r 'result-kind))))
880
881(test-equal '(fail pass)
882 (on-test-runner
883 (lambda ()
884 (test-assert (= 1 2))
885 (test-assert (= 1 1)))
886 (lambda (r)
887 (test-result-ref r 'result-kind))))
888
889(test-end "9.2. test-result-ref")
890
891(test-begin "9.3. test-result-set!")
892
893(test-equal '(100 100)
894 (on-test-runner
895 (lambda ()
896 (test-assert (= 1 2))
897 (test-assert (= 1 1)))
898 (lambda (r)
899 (test-result-set! r 'foo 100)
900 (test-result-ref r 'foo))))
901
902(test-end "9.3. test-result-set!")
903
904(test-end "9. Test Result Properties")
905
906;;;
907;;;
908;;;
909
910#| Time to stop having fun...
911
912(test-begin "9. For fun, some meta-test errors")
913
914(test-equal
915 "9.1. Really PASSes, but test like it should FAIL"
916 '(() ("b") () () ())
917 (triv-runner
918 (lambda ()
919 (test-assert "b" #t))))
920
921(test-expect-fail "9.2. Expect to FAIL and do so")
922(test-expect-fail "9.3. Expect to FAIL but PASS")
923(test-skip "9.4. SKIP this one")
924
925(test-assert "9.2. Expect to FAIL and do so" #f)
926(test-assert "9.3. Expect to FAIL but PASS" #t)
927(test-assert "9.4. SKIP this one" #t)
928
929(test-end)
930 |#
931
932(test-end "SRFI 64 - Meta-Test Suite")
933
934;;;
Unnamed repository; edit this file 'description' to name the repository.