summaryrefslogtreecommitdiff
path: root/test-suite/tests/srfi-64-test.scm
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/srfi-64-test.scm')
-rw-r--r--test-suite/tests/srfi-64-test.scm934
1 files changed, 934 insertions, 0 deletions
diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
new file mode 100644
index 000000000..3cd67d0ef
--- /dev/null
+++ b/test-suite/tests/srfi-64-test.scm
@@ -0,0 +1,934 @@
+;;;
+;;; This is a test suite written in the notation of
+;;; SRFI-64, A Scheme API for test suites
+;;;
+
+(test-begin "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;; Ironically, in order to set up the meta-test environment,
+;;; we have to invoke one of the most sophisticated features:
+;;; custom test runners
+;;;
+
+;;; The `prop-runner' invokes `thunk' in the context of a new
+;;; test runner, and returns the indicated properties of the
+;;; last-executed test result.
+
+(define (prop-runner props thunk)
+ (let ((r (test-runner-null))
+ (plist '()))
+ ;;
+ (test-runner-on-test-end!
+ r
+ (lambda (runner)
+ (set! plist (test-result-alist runner))))
+ ;;
+ (test-with-runner r (thunk))
+ ;; reorder the properties so they are in the order
+ ;; given by `props'. Note that any property listed in `props'
+ ;; that is not in the property alist will occur as #f
+ (map (lambda (k)
+ (assq k plist))
+ props)))
+
+;;; `on-test-runner' creates a null test runner and then
+;;; arranged for `visit' to be called with the runner
+;;; whenever a test is run. The results of the calls to
+;;; `visit' are returned in a list
+
+(define (on-test-runner thunk visit)
+ (let ((r (test-runner-null))
+ (results '()))
+ ;;
+ (test-runner-on-test-end!
+ r
+ (lambda (runner)
+ (set! results (cons (visit r) results))))
+ ;;
+ (test-with-runner r (thunk))
+ (reverse results)))
+
+;;;
+;;; The `triv-runner' invokes `thunk'
+;;; and returns a list of 6 lists, the first 5 of which
+;;; are a list of the names of the tests that, respectively,
+;;; PASS, FAIL, XFAIL, XPASS, and SKIP.
+;;; The last item is a list of counts.
+;;;
+
+(define (triv-runner thunk)
+ (let ((r (test-runner-null))
+ (accum-pass '())
+ (accum-fail '())
+ (accum-xfail '())
+ (accum-xpass '())
+ (accum-skip '()))
+ ;;
+ (test-runner-on-bad-count!
+ r
+ (lambda (runner count expected-count)
+ (error (string-append "bad count " (number->string count)
+ " but expected "
+ (number->string expected-count)))))
+ (test-runner-on-bad-end-name!
+ r
+ (lambda (runner begin end)
+ (error (string-append "bad end group name " end
+ " but expected " begin))))
+ (test-runner-on-test-end!
+ r
+ (lambda (runner)
+ (let ((n (test-runner-test-name runner)))
+ (case (test-result-kind runner)
+ ((pass) (set! accum-pass (cons n accum-pass)))
+ ((fail) (set! accum-fail (cons n accum-fail)))
+ ((xpass) (set! accum-xpass (cons n accum-xpass)))
+ ((xfail) (set! accum-xfail (cons n accum-xfail)))
+ ((skip) (set! accum-skip (cons n accum-skip)))))))
+ ;;
+ (test-with-runner r (thunk))
+ (list (reverse accum-pass) ; passed as expected
+ (reverse accum-fail) ; failed, but was expected to pass
+ (reverse accum-xfail) ; failed as expected
+ (reverse accum-xpass) ; passed, but was expected to fail
+ (reverse accum-skip) ; was not executed
+ (list (test-runner-pass-count r)
+ (test-runner-fail-count r)
+ (test-runner-xfail-count r)
+ (test-runner-xpass-count r)
+ (test-runner-skip-count r)))))
+
+(define (path-revealing-runner thunk)
+ (let ((r (test-runner-null))
+ (seq '()))
+ ;;
+ (test-runner-on-test-end!
+ r
+ (lambda (runner)
+ (set! seq (cons (list (test-runner-group-path runner)
+ (test-runner-test-name runner))
+ seq))))
+ (test-with-runner r (thunk))
+ (reverse seq)))
+
+;;;
+;;; Now we can start testing compliance with SRFI-64
+;;;
+
+(test-begin "1. Simple test-cases")
+
+(test-begin "1.1. test-assert")
+
+(define (t)
+ (triv-runner
+ (lambda ()
+ (test-assert "a" #t)
+ (test-assert "b" #f))))
+
+(test-equal
+ "1.1.1. Very simple"
+ '(("a") ("b") () () () (1 1 0 0 0))
+ (t))
+
+(test-equal
+ "1.1.2. A test with no name"
+ '(("a") ("") () () () (1 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
+
+(test-equal
+ "1.1.3. Tests can have the same name"
+ '(("a" "a") () () () () (2 0 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
+
+(define (choke)
+ (vector-ref '#(1 2) 3))
+
+(test-equal
+ "1.1.4. One way to FAIL is to throw an error"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" (choke)))))
+
+(test-end);1.1
+
+(test-begin "1.2. test-eqv")
+
+(define (mean x y)
+ (/ (+ x y) 2.0))
+
+(test-equal
+ "1.2.1. Simple numerical equivalence"
+ '(("c") ("a" "b") () () () (1 2 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-eqv "a" (mean 3 5) 4)
+ (test-eqv "b" (mean 3 5) 4.5)
+ (test-eqv "c" (mean 3 5) 4.0))))
+
+(test-end);1.2
+
+(test-end "1. Simple test-cases")
+
+;;;
+;;;
+;;;
+
+(test-begin "2. Tests for catching errors")
+
+(test-begin "2.1. test-error")
+
+(test-equal
+ "2.1.1. Baseline test; PASS with no optional args"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; PASS
+ (test-error (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.2. Baseline test; FAIL with no optional args"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; FAIL: the expr does not raise an error and `test-error' is
+ ;; claiming that it will, so this test should FAIL
+ (test-error (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.3. PASS with a test name and error type"
+ '(("a") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ ;; PASS
+ (test-error "a" #t (vector-ref '#(1 2) 9)))))
+
+(test-end "2.1. test-error")
+
+(test-end "2. Tests for catching errors")
+
+;;;
+;;;
+;;;
+
+(test-begin "3. Test groups and paths")
+
+(test-equal
+ "3.1. test-begin with unspecific test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "b" #t)
+ (test-end))))
+
+(test-equal
+ "3.2. test-begin with name-matching test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "b" #t)
+ (test-end "a"))))
+
+;;; since the error raised by `test-end' on a mismatch is not a test
+;;; error, we actually expect the triv-runner itself to fail
+
+(test-error
+ "3.3. test-begin with mismatched test-end"
+#t
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "b" #t)
+ (test-end "x"))))
+
+(test-equal
+ "3.4. test-begin with name and count"
+ '(("b" "c") () () () () (2 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-begin "a" 2)
+ (test-assert "b" #t)
+ (test-assert "c" #t)
+ (test-end "a"))))
+
+;; similarly here, a mismatched count is a lexical error
+;; and not a test failure...
+
+(test-error
+ "3.5. test-begin with mismatched count"
+ #t
+ (triv-runner
+ (lambda ()
+ (test-begin "a" 99)
+ (test-assert "b" #t)
+ (test-end "a"))))
+
+(test-equal
+ "3.6. introspecting on the group path"
+ '((() "w")
+ (("a" "b") "x")
+ (("a" "b") "y")
+ (("a") "z"))
+ ;;
+ ;; `path-revealing-runner' is designed to return a list
+ ;; of the tests executed, in order. Each entry is a list
+ ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
+ ;; of test groups starting from the topmost
+ ;;
+ (path-revealing-runner
+ (lambda ()
+ (test-assert "w" #t)
+ (test-begin "a")
+ (test-begin "b")
+ (test-assert "x" #t)
+ (test-assert "y" #t)
+ (test-end)
+ (test-assert "z" #t))))
+
+
+(test-end "3. Test groups and paths")
+
+;;;
+;;;
+;;;
+
+(test-begin "4. Handling set-up and cleanup")
+
+(test-equal "4.1. Normal exit path"
+ '(in 1 2 out)
+ (let ((ex '()))
+ (define (do s)
+ (set! ex (cons s ex)))
+ ;;
+ (triv-runner
+ (lambda ()
+ (test-group-with-cleanup
+ "foo"
+ (do 'in)
+ (do 1)
+ (do 2)
+ (do 'out))))
+ (reverse ex)))
+
+(test-equal "4.2. Exception exit path"
+ '(in 1 out)
+ (let ((ex '()))
+ (define (do s)
+ (set! ex (cons s ex)))
+ ;;
+ ;; the outer runner is to run the `test-error' in, to
+ ;; catch the exception raised in the inner runner,
+ ;; since we don't want to depend on any other
+ ;; exception-catching support
+ ;;
+ (triv-runner
+ (lambda ()
+ (test-error
+ (triv-runner
+ (lambda ()
+ (test-group-with-cleanup
+ "foo"
+ (do 'in) (test-assert #t)
+ (do 1) (test-assert #t)
+ (choke) (test-assert #t)
+ (do 2) (test-assert #t)
+ (do 'out)))))))
+ (reverse ex)))
+
+(test-end "4. Handling set-up and cleanup")
+
+;;;
+;;;
+;;;
+
+(test-begin "5. Test specifiers")
+
+(test-begin "5.1. test-match-named")
+
+(test-equal "5.1.1. match test names"
+ '(("y") () () () ("x") (1 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-skip (test-match-name "x"))
+ (test-assert "x" #t)
+ (test-assert "y" #t))))
+
+(test-equal "5.1.2. but not group names"
+ '(("z") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-skip (test-match-name "x"))
+ (test-begin "x")
+ (test-assert "z" #t)
+ (test-end))))
+
+(test-end)
+
+(test-begin "5.2. test-match-nth")
+;; See also: [6.4. Short-circuit evaluation]
+
+(test-equal "5.2.1. skip the nth one after"
+ '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-nth 2))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP
+ (test-assert "y" #t) ; 3
+ (test-assert "z" #t)))) ; 4
+
+(test-equal "5.2.2. skip m, starting at n"
+ '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-nth 2 2))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP
+ (test-assert "y" #t) ; 3 SKIP
+ (test-assert "z" #t)))) ; 4
+
+(test-end)
+
+(test-begin "5.3. test-match-any")
+(test-equal "5.3.1. basic disjunction"
+ '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-any (test-match-nth 3)
+ (test-match-name "x")))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP(NAME)
+ (test-assert "y" #t) ; 3 SKIP(COUNT)
+ (test-assert "z" #t)))) ; 4
+
+(test-equal "5.3.2. disjunction is commutative"
+ '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-any (test-match-name "x")
+ (test-match-nth 3)))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP(NAME)
+ (test-assert "y" #t) ; 3 SKIP(COUNT)
+ (test-assert "z" #t)))) ; 4
+
+(test-end)
+
+(test-begin "5.4. test-match-all")
+(test-equal "5.4.1. basic conjunction"
+ '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-all (test-match-nth 2 2)
+ (test-match-name "x")))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
+ (test-assert "y" #t) ; 3 SKIP(COUNT)
+ (test-assert "z" #t)))) ; 4
+
+(test-equal "5.4.2. conjunction is commutative"
+ '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-assert "v" #t)
+ (test-skip (test-match-all (test-match-name "x")
+ (test-match-nth 2 2)))
+ (test-assert "w" #t) ; 1
+ (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT)
+ (test-assert "y" #t) ; 3 SKIP(COUNT)
+ (test-assert "z" #t)))) ; 4
+
+(test-end)
+
+(test-end "5. Test specifiers")
+
+;;;
+;;;
+;;;
+
+(test-begin "6. Skipping selected tests")
+
+(test-equal
+ "6.1. Skip by specifier - match-name"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip (test-match-name "y"))
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; SKIP
+ (test-end))))
+
+(test-equal
+ "6.2. Shorthand specifiers"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "y")
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; SKIP
+ (test-end))))
+
+(test-begin "6.3. Specifier Stack")
+
+(test-equal
+ "6.3.1. Clearing the Specifier Stack"
+ '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "y")
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; SKIP
+ (test-end)
+ (test-begin "b")
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; FAIL
+ (test-end))))
+
+(test-equal
+ "6.3.2. Inheriting the Specifier Stack"
+ '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
+ (triv-runner
+ (lambda ()
+ (test-skip "y")
+ (test-begin "a")
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; SKIP
+ (test-end)
+ (test-begin "b")
+ (test-assert "x" #t) ; PASS
+ (test-assert "y" #f) ; SKIP
+ (test-end))))
+
+(test-end);6.3
+
+(test-begin "6.4. Short-circuit evaluation")
+
+(test-equal
+ "6.4.1. In test-match-all"
+ '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip (test-match-all "y" (test-match-nth 2)))
+ ;; let's label the substructure forms so we can
+ ;; see which one `test-match-nth' is going to skip
+ ;; ; # "y" 2 result
+ (test-assert "x" #t) ; 1 - #f #f PASS
+ (test-assert "y" #f) ; 2 - #t #t SKIP
+ (test-assert "y" #f) ; 3 - #t #f FAIL
+ (test-assert "x" #f) ; 4 - #f #f FAIL
+ (test-assert "z" #f) ; 5 - #f #f FAIL
+ (test-end))))
+
+(test-equal
+ "6.4.2. In separate skip-list entries"
+ '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "y")
+ (test-skip (test-match-nth 2))
+ ;; let's label the substructure forms so we can
+ ;; see which one `test-match-nth' is going to skip
+ ;; ; # "y" 2 result
+ (test-assert "x" #t) ; 1 - #f #f PASS
+ (test-assert "y" #f) ; 2 - #t #t SKIP
+ (test-assert "y" #f) ; 3 - #t #f SKIP
+ (test-assert "x" #f) ; 4 - #f #f FAIL
+ (test-assert "z" #f) ; 5 - #f #f FAIL
+ (test-end))))
+
+(test-begin "6.4.3. Skipping test suites")
+
+(test-equal
+ "6.4.3.1. Introduced using 'test-begin'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "b")
+ (test-begin "b") ; not skipped
+ (test-assert "x" #t)
+ (test-end "b")
+ (test-end "a"))))
+
+(test-expect-fail 1) ;; ???
+(test-equal
+ "6.4.3.2. Introduced using 'test-group'"
+ '(() () () () () (0 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "b")
+ (test-group
+ "b" ; skipped
+ (test-assert "x" #t))
+ (test-end "a"))))
+
+(test-equal
+ "6.4.3.3. Non-skipped 'test-group'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-skip "c")
+ (test-group "b" (test-assert "x" #t))
+ (test-end "a"))))
+
+(test-end) ; 6.4.3
+
+(test-end);6.4
+
+(test-end "6. Skipping selected tests")
+
+;;;
+;;;
+;;;
+
+(test-begin "7. Expected failures")
+
+(test-equal "7.1. Simple example"
+ '(() ("x") ("z") () () (0 1 1 0 0))
+ (triv-runner
+ (lambda ()
+ (test-assert "x" #f)
+ (test-expect-fail "z")
+ (test-assert "z" #f))))
+
+(test-equal "7.2. Expected exception"
+ '(() ("x") ("z") () () (0 1 1 0 0))
+ (triv-runner
+ (lambda ()
+ (test-assert "x" #f)
+ (test-expect-fail "z")
+ (test-assert "z" (choke)))))
+
+(test-equal "7.3. Unexpectedly PASS"
+ '(() () ("y") ("x") () (0 0 1 1 0))
+ (triv-runner
+ (lambda ()
+ (test-expect-fail "x")
+ (test-expect-fail "y")
+ (test-assert "x" #t)
+ (test-assert "y" #f))))
+
+
+
+(test-end "7. Expected failures")
+
+;;;
+;;;
+;;;
+
+(test-begin "8. Test-runner")
+
+;;;
+;;; Because we want this test suite to be accurate even
+;;; when the underlying implementation chooses to use, e.g.,
+;;; a global variable to implement what could be thread variables
+;;; or SRFI-39 parameter objects, we really need to save and restore
+;;; their state ourselves
+;;;
+(define (with-factory-saved thunk)
+ (let* ((saved (test-runner-factory))
+ (result (thunk)))
+ (test-runner-factory saved)
+ result))
+
+(test-begin "8.1. test-runner-current")
+(test-assert "8.1.1. automatically restored"
+ (let ((a 0)
+ (b 1)
+ (c 2))
+ ;
+ (triv-runner
+ (lambda ()
+ (set! a (test-runner-current))
+ ;;
+ (triv-runner
+ (lambda ()
+ (set! b (test-runner-current))))
+ ;;
+ (set! c (test-runner-current))))
+ ;;
+ (and (eq? a c)
+ (not (eq? a b)))))
+
+(test-end)
+
+(test-begin "8.2. test-runner-simple")
+(test-assert "8.2.1. default on-test hook"
+ (eq? (test-runner-on-test-end (test-runner-simple))
+ test-on-test-end-simple))
+(test-assert "8.2.2. default on-final hook"
+ (eq? (test-runner-on-final (test-runner-simple))
+ test-on-final-simple))
+(test-end)
+
+(test-begin "8.3. test-runner-factory")
+
+(test-assert "8.3.1. default factory"
+ (eq? (test-runner-factory) test-runner-simple))
+
+(test-assert "8.3.2. settable factory"
+ (with-factory-saved
+ (lambda ()
+ (test-runner-factory test-runner-null)
+ ;; we have no way, without bringing in other SRFIs,
+ ;; to make sure the following doesn't print anything,
+ ;; but it shouldn't:
+ (test-with-runner
+ (test-runner-create)
+ (lambda ()
+ (test-begin "a")
+ (test-assert #t) ; pass
+ (test-assert #f) ; fail
+ (test-assert (vector-ref '#(3) 10)) ; fail with error
+ (test-end "a")))
+ (eq? (test-runner-factory) test-runner-null))))
+
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.4. test-runner-create")
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.5. test-runner-factory")
+(test-end)
+
+(test-begin "8.6. test-apply")
+(test-equal "8.6.1. Simple (form 1) test-apply"
+ '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "w" #t)
+ (test-apply
+ (test-match-name "p")
+ (lambda ()
+ (test-begin "p")
+ (test-assert "x" #t)
+ (test-end)
+ (test-begin "z")
+ (test-assert "p" #t) ; only this one should execute in here
+ (test-end)))
+ (test-assert "v" #t))))
+
+(test-equal "8.6.2. Simple (form 2) test-apply"
+ '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "w" #t)
+ (test-apply
+ (test-runner-current)
+ (test-match-name "p")
+ (lambda ()
+ (test-begin "p")
+ (test-assert "x" #t)
+ (test-end)
+ (test-begin "z")
+ (test-assert "p" #t) ; only this one should execute in here
+ (test-end)))
+ (test-assert "v" #t))))
+
+(test-expect-fail 1) ;; depends on all test-match-nth being called.
+(test-equal "8.6.3. test-apply with skips"
+ '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
+ (triv-runner
+ (lambda ()
+ (test-begin "a")
+ (test-assert "w" #t)
+ (test-skip (test-match-nth 2))
+ (test-skip (test-match-nth 4))
+ (test-apply
+ (test-runner-current)
+ (test-match-name "p")
+ (test-match-name "q")
+ (lambda ()
+ ; only execute if SKIP=no and APPLY=yes
+ (test-assert "x" #t) ; # 1 SKIP=no APPLY=no
+ (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes
+ (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes
+ (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no
+ 0))
+ (test-assert "v" #t))))
+
+;;; Unfortunately, since there is no way to UNBIND the current test runner,
+;;; there is no way to test the behavior of `test-apply' in the absence
+;;; of a current runner within our little meta-test framework.
+;;;
+;;; To test the behavior manually, you should be able to invoke:
+;;;
+;;; (test-apply "a" (lambda () (test-assert "a" #t)))
+;;;
+;;; from the top level (with SRFI 64 available) and it should create a
+;;; new, default (simple) test runner.
+
+(test-end)
+
+;;; This entire suite depends heavily on 'test-with-runner'. If it didn't
+;;; work, this suite would probably go down in flames
+(test-begin "8.7. test-with-runner")
+(test-end)
+
+;;; Again, this suite depends heavily on many of the test-runner
+;;; components. We'll just test those that aren't being exercised
+;;; by the meta-test framework
+(test-begin "8.8. test-runner components")
+
+(define (auxtrack-runner thunk)
+ (let ((r (test-runner-null)))
+ (test-runner-aux-value! r '())
+ (test-runner-on-test-end! r (lambda (r)
+ (test-runner-aux-value!
+ r
+ (cons (test-runner-test-name r)
+ (test-runner-aux-value r)))))
+ (test-with-runner r (thunk))
+ (reverse (test-runner-aux-value r))))
+
+(test-equal "8.8.1. test-runner-aux-value"
+ '("x" "" "y")
+ (auxtrack-runner
+ (lambda ()
+ (test-assert "x" #t)
+ (test-begin "a")
+ (test-assert #t)
+ (test-end)
+ (test-assert "y" #f))))
+
+(test-end) ; 8.8
+
+(test-end "8. Test-runner")
+
+(test-begin "9. Test Result Properties")
+
+(test-begin "9.1. test-result-alist")
+
+(define (symbol-alist? l)
+ (if (null? l)
+ #t
+ (and (pair? l)
+ (pair? (car l))
+ (symbol? (caar l))
+ (symbol-alist? (cdr l)))))
+
+;;; check the various syntactic forms
+
+(test-assert (symbol-alist?
+ (car (on-test-runner
+ (lambda ()
+ (test-assert #t))
+ (lambda (r)
+ (test-result-alist r))))))
+
+(test-assert (symbol-alist?
+ (car (on-test-runner
+ (lambda ()
+ (test-assert #t))
+ (lambda (r)
+ (test-result-alist r))))))
+
+;;; check to make sure the required properties are returned
+
+(test-equal '((result-kind . pass))
+ (prop-runner
+ '(result-kind)
+ (lambda ()
+ (test-assert #t)))
+ )
+
+(test-equal
+ '((result-kind . fail)
+ (expected-value . 2)
+ (actual-value . 3))
+ (prop-runner
+ '(result-kind expected-value actual-value)
+ (lambda ()
+ (test-equal 2 (+ 1 2)))))
+
+(test-end "9.1. test-result-alist")
+
+(test-begin "9.2. test-result-ref")
+
+(test-equal '(pass)
+ (on-test-runner
+ (lambda ()
+ (test-assert #t))
+ (lambda (r)
+ (test-result-ref r 'result-kind))))
+
+(test-equal '(pass)
+ (on-test-runner
+ (lambda ()
+ (test-assert #t))
+ (lambda (r)
+ (test-result-ref r 'result-kind))))
+
+(test-equal '(fail pass)
+ (on-test-runner
+ (lambda ()
+ (test-assert (= 1 2))
+ (test-assert (= 1 1)))
+ (lambda (r)
+ (test-result-ref r 'result-kind))))
+
+(test-end "9.2. test-result-ref")
+
+(test-begin "9.3. test-result-set!")
+
+(test-equal '(100 100)
+ (on-test-runner
+ (lambda ()
+ (test-assert (= 1 2))
+ (test-assert (= 1 1)))
+ (lambda (r)
+ (test-result-set! r 'foo 100)
+ (test-result-ref r 'foo))))
+
+(test-end "9.3. test-result-set!")
+
+(test-end "9. Test Result Properties")
+
+;;;
+;;;
+;;;
+
+#| Time to stop having fun...
+
+(test-begin "9. For fun, some meta-test errors")
+
+(test-equal
+ "9.1. Really PASSes, but test like it should FAIL"
+ '(() ("b") () () ())
+ (triv-runner
+ (lambda ()
+ (test-assert "b" #t))))
+
+(test-expect-fail "9.2. Expect to FAIL and do so")
+(test-expect-fail "9.3. Expect to FAIL but PASS")
+(test-skip "9.4. SKIP this one")
+
+(test-assert "9.2. Expect to FAIL and do so" #f)
+(test-assert "9.3. Expect to FAIL but PASS" #t)
+(test-assert "9.4. SKIP this one" #t)
+
+(test-end)
+ |#
+
+(test-end "SRFI 64 - Meta-Test Suite")
+
+;;;