[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
|
From: |
Tomas Volf |
|
Subject: |
bug#73605: [PATCH] Replace SRFI-64 with a new implementation. |
|
Date: |
Wed, 2 Oct 2024 21:27:59 +0200 |
The bundled (reference) implementation was of somewhat mixed quality and
it failed to follow standard in multiple places. This commit replaces
it with a new one, written from scratch to follow the standard as close
as possible.
* module/srfi/srfi-64/testing.scm: Delete file.
* module/srfi/srfi-64.scm: Replace with new implementation.
* am/bootstrap.am (srfi/srfi-64.go): Remove extra dependencies.
(NOCOMP_SOURCES): Remove srfi/srfi-64/testing.scm.
* test-suite/tests/srfi-64-test.scm
("8.6.1. Simple (form 1) test-apply")
("8.6.2. Simple (form 2) test-apply"): Adjust tests to follow the
specification.
---
The current implementation of SRFI-64 is buggy and does not even follow the
specification in many places. This blog post[0] lists some of the bugs found.
This commit it by a new one written from scratch, that tries to solve both of
those problems.
The code library was tested with GNU Guix (probably biggest user of SRFI-64?)
and it works. There are only 4 tests that used to pass and do not with a new
implementation. In all of those cases, the bug in the test itself was masked by
non-compliance of the previous SRFI-64 implementation. More details here [1].
Tests in Guile (srfi-64-test.scm) did require two changes, the test code does
not (in my opinion) follow the specification. Since spec says
> Any skip specifiers introduced by a test-skip are removed by a following
> non-nested test-end.
The test-ends on lines 729 and 747 are nested, they are not top-level, so the
skip specifier should not be cleared. But I am opened to debate on this one.
During writing the implementation, I produced many (over 300) test files which
are available here[2]. I am not sure whether to have them in this commit as
well. Opinions?
Last remaining point to note is that there is some additional functionality not
covered by the specification included (define-test, ...). I can remove it, by I
consider it useful. Documentation is currently lacking, but that is
intentional, since #71300 is not accepted yet, and logically it would belong in
there.
0: https://wolfsden.cz/blog/post/state-of-srfi-64.html
1: https://emacs.ch/@graywolf/112944743928293340
2: https://git.wolfsden.cz/guile-wolfsden/tree/tests/srfi-64
am/bootstrap.am | 2 -
module/srfi/srfi-64.scm | 1011 +++++++++++++++++++++++++++-
module/srfi/srfi-64/testing.scm | 1044 -----------------------------
test-suite/tests/srfi-64-test.scm | 4 +-
4 files changed, 978 insertions(+), 1083 deletions(-)
delete mode 100644 module/srfi/srfi-64/testing.scm
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 9e5fca0db..d4a415e35 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -54,7 +54,6 @@ COMPILE = $(AM_V_GUILEC)
\
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm
ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
@@ -438,7 +437,6 @@ NOCOMP_SOURCES = \
ice-9/r7rs-libraries.scm \
ice-9/quasisyntax.scm \
srfi/srfi-42/ec.scm \
- srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \
system/base/lalr.upstream.scm \
system/repl/describe.scm \
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
index 925726f5c..1f60a72e5 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -1,6 +1,5 @@
-;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
+;;; Copyright (C) 2024 Tomas Volf <~@wolfsden.cz>
-;; Copyright (C) 2014 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -16,41 +15,983 @@
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;; Commentary:
+
+;;; Implementation of the SRFI-64. In contrast to the reference
+;;; implementation of @samp{(srfi srfi-64)} it aims to implement the
+;;; standard fully and correctly.
+
+;;; Code:
+
(define-module (srfi srfi-64)
+ #:use-module (ice-9 exceptions)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:export
- (test-begin
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
- #:declarative? #f) ; #f needed for test-log-to-file
+ (
+ ;; Going by individual sections of the specification, top to bottom:
+ ;; Simple test-cases
+ test-approximate
+ test-assert
+ test-eq
+ test-equal
+ test-eqv
+ ;; Tests for catching errors
+ test-error
+ ;; Testing syntax
+ test-read-eval-string
+ ;; Test groups and paths
+ test-begin
+ test-end
+ test-group
+ ;; Handling set-up and cleanup
+ test-group-with-cleanup
+ ;; Test specifiers
+ test-match-all
+ test-match-any
+ test-match-name
+ test-match-nth
+ ;; Skipping selected tests
+ test-expect-fail
+ test-skip
+ ;; Test-runner
+ test-runner-create
+ test-runner-current
+ test-runner-factory
+ test-runner-get
+ test-runner-null
+ test-runner-simple
+ test-runner?
+ ;; Running specific tests with a specified runner
+ test-apply
+ test-with-runner
+ ;; Result kind
+ test-passed?
+ test-result-kind
+ ;; Test result properties
+ test-result-alist
+ test-result-clear
+ test-result-ref
+ test-result-remove
+ test-result-set!
+ ;; Call-back hooks
+ test-runner-on-bad-count
+ test-runner-on-bad-count!
+ test-runner-on-bad-end-name
+ test-runner-on-bad-end-name!
+ test-runner-on-final
+ test-runner-on-final!
+ test-runner-on-group-begin
+ test-runner-on-group-begin!
+ test-runner-on-group-end
+ test-runner-on-group-end!
+ test-runner-on-test-begin
+ test-runner-on-test-begin!
+ test-runner-on-test-end
+ test-runner-on-test-end!
+ ;; Simple runner call-back functions
+ test-on-bad-count-simple
+ test-on-bad-end-name-simple
+ test-on-group-begin-simple
+ test-on-group-end-simple
+ test-on-test-begin-simple
+ test-on-test-end-simple
+ ;; Test-runner components
+ test-runner-aux-value
+ test-runner-aux-value!
+ test-runner-fail-count
+ test-runner-group-path
+ test-runner-group-stack
+ test-runner-pass-count
+ test-runner-reset
+ test-runner-skip-count
+ test-runner-test-name
+ test-runner-xfail-count
+ test-runner-xpass-count
+
+ ;; Additional functionality not in SRFI-64:
+ define-test
+ test-procedure?
+ test-thunk
+
+ &bad-end-name
+ bad-end-name?
+ bad-end-name-begin-name
+ bad-end-name-end-name))
+
+(define (set-documentation! symbol docstring)
+ "Set the docstring for @var{symbol} in current module to @var{docstring}.
+
+Do not use this procedure for forms that already support setting the
+docstring. Should directly follow the definition of @var{symbol}.
+
+Example:
+
+@lisp
+(define answer 42)
+(set-documentation! 'answer
+ \"The answer to life, the universe, and everything.\")
+@end lisp"
+ (set-object-property! (module-ref (current-module) symbol)
+ 'documentation
+ docstring))
(cond-expand-provide (current-module) '(srfi-64))
-(include-from-path "srfi/srfi-64/testing.scm")
+(define-record-type <test-runner>
+ (%make-test-runner)
+ test-runner?
+ ;; Test result properties
+ (result-alist test-runner-result-alist test-runner-result-alist!)
+ ;; Call-back hooks
+ (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!)
+ (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ (on-final test-runner-on-final test-runner-on-final!)
+ (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+ (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+ (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end test-runner-on-test-end test-runner-on-test-end!)
+ ;; Test-runner components
+ (counts test-runner-counts test-runner-counts!)
+
+ (test-name test-runner-test-name test-runner-test-name!)
+
+ (group-stack test-runner-group-stack test-runner-group-stack!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!)
+
+ ;; Implementation details
+ (fail-list test-runner-fail-list test-runner-fail-list!)
+ (groups test-runner-groups test-runner-groups!)
+ (run-list test-runner-run-list test-runner-run-list!)
+ (skip-list test-runner-skip-list test-runner-skip-list!))
+
+(define (test-runner-reset runner)
+ (test-runner-result-alist! runner '())
+
+ (test-runner-counts! runner '())
+
+ (test-runner-test-name! runner #f)
+
+ (test-runner-group-stack! runner '())
+
+ (test-runner-fail-list! runner '())
+ (test-runner-groups! runner '())
+ ;; run-list is not documented as part of the test-runner, so it should *not*
+ ;; be cleared.
+ (test-runner-skip-list! runner '()))
+
+(define (test-runner-group-path runner)
+ "Return list of names of groups we're nested in, with the outermost group
+first."
+ (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-fail-count r)
+ "Return the number of tests that failed, but were expected to pass."
+ (or (assq-ref (test-runner-counts r) 'fail) 0))
+
+(define (test-runner-pass-count r)
+ "Return the number of tests that passed, and were expected to pass."
+ (or (assq-ref (test-runner-counts r) 'pass) 0))
+
+(define (test-runner-skip-count r)
+ "Return the number of tests or test groups that were skipped."
+ (or (assq-ref (test-runner-counts r) 'skip) 0))
+
+(define (test-runner-xfail-count r)
+ "Return the number of tests that failed, and were expected to fail."
+ (or (assq-ref (test-runner-counts r) 'xfail) 0))
+
+(define (test-runner-xpass-count r)
+ "Return the number of tests that passed, but were expected to fail."
+ (or (assq-ref (test-runner-counts r) 'xpass) 0))
+
+
+;;;
+;;; Test specifiers
+;;;
+(define (test-match-name name)
+ "Return a specifier matching the current test name against @var{name}."
+ (λ (runner)
+ (equal? name (test-runner-test-name runner))))
+
+(define* (test-match-nth n #:optional (count 1))
+ "Return a stateful predicate. A counter keeps track of how many times it
+has been called. The predicate matches the @var{n}'th time it is
+called (where 1 is the first time), and the next @code{(- @var{count} 1)}
+times, where @var{count} defaults to 1."
+ (let ((i 0)
+ (m (+ n count -1)))
+ (λ (runner)
+ (set! i (1+ i))
+ (and (>= i n) (<= i m)))))
+
+(define (obj->specifier obj)
+ "Convert an object to a specifier accounting for the convenience
+short-hands."
+ (match obj
+ ((? procedure? spec)
+ spec)
+ ((? string? name)
+ (test-match-name name))
+ ((? integer? count)
+ (test-match-nth 1 count))))
+
+(define (test-match-any . specifiers)
+ "Return specifier matching if any specifier in @var{specifiers} matches.
+Each specifier is applied, in order, so side-effects from a later specifier
+happen even if an earlier specifier is true."
+ (let ((specifiers (map obj->specifier specifiers)))
+ (λ (runner)
+ (fold (λ (specifier seed)
+ (or (specifier runner) seed))
+ #f
+ specifiers))))
+
+(define (test-match-all . specifiers)
+ "Return specifier matching if all @var{specifiers} match. Each specifier is
+applied, in order, so side-effects from a later specifier happen even if an
+earlier specifier is true."
+ (let ((specifiers (map obj->specifier specifiers)))
+ (λ (runner)
+ (fold (λ (specifier seed)
+ (and (specifier runner) seed))
+ #t
+ specifiers))))
+
+
+;;;
+;;; Skipping selected tests
+;;;
+(define (test-skip specifier)
+ "Evaluating test-skip adds the resulting specifier to the set of currently
+active skip-specifiers. Before each test (or test-group) the set of active
+skip-specifiers are applied to the active test-runner. If any specifier
+matches, then the test is skipped.
+
+@var{specifier} can be a predicate of one argument (the test runner), a
+string (used as if @code{(test-match-name @var{specifier})}) or an
+integer (used as if @code{(test-match-nth 1 @var{specifier})})."
+ (let ((r (test-runner-current)))
+ (test-runner-skip-list! r (cons (obj->specifier specifier)
+ (test-runner-skip-list r)))))
+
+(define (any-specifier-matches? specifiers)
+ "Does any specifier in @var{specifiers} match current test?
+
+All specifiers are always evaluated."
+ (let ((r (test-runner-current)))
+ (fold (λ (specifier seed)
+ (or (specifier r) seed))
+ #f
+ specifiers)))
+
+(define (should-skip?)
+ "Should current test be skipped?"
+ (any-specifier-matches? (test-runner-skip-list (test-runner-current))))
+
+
+;;;
+;;; Expected failures
+;;;
+(define (test-expect-fail specifier)
+ "Matching tests (where matching is defined as in test-skip) are expected to
+fail. This only affects test reporting, not test execution."
+ (let ((r (test-runner-current)))
+ (test-runner-fail-list! r (cons (obj->specifier specifier)
+ (test-runner-fail-list r)))))
+
+(define (should-fail?)
+ "Should the current test fail?"
+ (any-specifier-matches? (test-runner-fail-list (test-runner-current))))
+
+
+;;;
+;;; Test result properties
+;;;
+(define* (test-result-ref runner pname #:optional default)
+ "Returns the property value associated with the @var{pname} property name.
+If there is no value associated with @var{pname} return @var{default}, or
+@code{#f} if @var{default} is not specified."
+ (or (assoc-ref (test-runner-result-alist runner) pname)
+ default))
+
+(define (test-result-set! runner pname value)
+ "Sets the property value associated with the @var{pname} property name to
+@var{value}."
+ (test-runner-result-alist! runner
+ (assoc-set! (test-runner-result-alist runner)
+ pname
+ value)))
+
+(define (test-result-remove runner pname)
+ "Remove the property with the name @var{pname}."
+ (test-runner-result-alist! runner
+ (assoc-remove! (test-runner-result-alist runner)
+ pname)))
+
+(define (test-result-clear runner)
+ "Remove all result properties."
+ ;; Standard says the following for test-result-alist:
+ ;; > However, a test-result-clear does not modify the returned alist.
+ ;;
+ ;; Therefore we assign a new empty list instead of removing all entries.
+ (test-runner-result-alist! runner '()))
+
+(define test-result-alist test-runner-result-alist)
+(set-documentation! 'test-result-alist
+ "Returns an association list of the current result properties. It is
+unspecified if the result shares state with the test-runner. The result
+should not be modified; on the other hand, the result may be implicitly
+modified by future @code{test-result-set!} or @code{test-result-remove} calls.
+However, a @code{test-result-clear} does not modify the returned alist.")
+
+
+;;;
+;;; Result kind
+;;;
+(define* (test-result-kind #:optional (runner (test-runner-current)))
+ "Result code of most recent test. Returns @code{#f} if no tests have been
run yet.
+If we have started on a new test, but do not have a result yet, then the
+result kind is @code{'xfail} if the test is expected to fail, @code{'skip} if
+the test is supposed to be skipped, or @code{#f} otherwise."
+ (test-result-ref runner 'result-kind))
+
+(define* (test-passed? #:optional (runner (test-runner-current)))
+ "Is the value of @code{(test-result-kind [runner])} one of @code{'pass} or
+@code{'xpass}?
+
+This function is of little use, since @code{'xpass} is type of failure. You
+should write your own wrapper checking @code{'pass} and @code{'xfail}
+instead."
+ (let ((result (test-result-kind runner)))
+ (or (eq? result 'pass)
+ (eq? result 'xpass))))
+
+
+;;;
+;;; Simple test runner
+;;;
+(define (test-on-bad-count-simple runner actual-count expected-count)
+ "Log the discrepancy between expected and actual test counts."
+ (format #t "*** Expected to run ~a tests, but ~a was executed. ***~%"
+ expected-count actual-count))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ "Log the discrepancy between the -begin and -end suite names."
+ (format #t "*** Suite name mismatch: test-begin (~a) != test-end (~a) ***~%"
+ begin-name end-name))
+
+(define (test-on-final-simple runner)
+ "Display summary of the test suite."
+ (display "*** Test suite finished. ***\n")
+ (for-each (λ (x)
+ (let ((count ((cdr x) runner)))
+ (when (> count 0)
+ (format #t "*** # of ~a: ~a~%" (car x) count))))
+ `(("expected passes " . ,test-runner-pass-count)
+ ("expected failures " . ,test-runner-xfail-count)
+ ("unexpected passes " . ,test-runner-xpass-count)
+ ("unexpected failures" . ,test-runner-fail-count)
+ ("skips " . ,test-runner-skip-count))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+ "Log that the group is beginning."
+ (format #t "*** Entering test group: ~a~@[ (# of tests: ~a) ~] ***~%"
+ suite-name count))
+
+(define (test-on-group-end-simple runner)
+ "Log that the group is ending."
+ ;; There is no portable way to get the test group name.
+ (format #t "*** Leaving test group: ~a ***~%"
+ (car (test-runner-group-stack runner))))
+
+(define (test-on-test-begin-simple runner)
+ "Do nothing."
+ #f)
+
+(define (test-on-test-end-simple runner)
+ "Log that test is done."
+ (define (maybe-print-prop prop pretty?)
+ (let* ((val (test-result-ref runner prop))
+ (val (string-trim-both
+ (with-output-to-string
+ (λ ()
+ (if pretty?
+ (pretty-print val #:per-line-prefix " ")
+ (display val)))))))
+ (when val
+ (format #t "~a: ~a~%" prop val))))
+
+ (let ((result-kind (test-result-kind runner)))
+ ;; Skip tests not executed due to run list.
+ (when result-kind
+ (format #t "* ~:@(~a~): ~a~%"
+ result-kind
+ (test-runner-test-name runner))
+ (unless (member result-kind '(pass xfail))
+ (maybe-print-prop 'source-file #f)
+ (maybe-print-prop 'source-line #f)
+ (maybe-print-prop 'source-form #t)
+ (maybe-print-prop 'expected-value #f)
+ (maybe-print-prop 'expected-error #t)
+ (maybe-print-prop 'actual-value #f)
+ (maybe-print-prop 'actual-error #t)))))
+
+(define (test-runner-simple)
+ "Creates a new simple test-runner, that prints errors and a summary on the
+standard output port."
+ (let ((r (%make-test-runner)))
+ (test-runner-reset r)
+
+ (test-runner-on-bad-count! r test-on-bad-count-simple)
+ (test-runner-on-bad-end-name! r test-on-bad-end-name-simple)
+ (test-runner-on-final! r test-on-final-simple)
+ (test-runner-on-group-begin! r test-on-group-begin-simple)
+ (test-runner-on-group-end! r test-on-group-end-simple)
+ (test-runner-on-test-begin! r test-on-test-begin-simple)
+ (test-runner-on-test-end! r test-on-test-end-simple)
+
+ (test-runner-run-list! r (make-parameter #f))
+ r))
+
+
+;;;
+;;; Test runner
+;;;
+
+(define test-runner-current (make-parameter #f))
+(set-documentation! 'test-runner-current
+ "Parameter representing currently installed test runner.")
+
+(define (test-runner-get)
+ "Get current test runner if any, raise an exception otherwise."
+ (or (test-runner-current)
+ (throw 'no-test-runner)))
+
+(define test-runner-factory (make-parameter test-runner-simple))
+(set-documentation! 'test-runner-factory
+ "Factory producing new test runner. Has to be a procedure of arity 0
+returning new test runner. Defaults to @code{test-runner-simple}.")
+
+(define (test-runner-create)
+ "Create a new test-runner. Equivalent to @code{((test-runner-factory))}."
+ ((test-runner-factory)))
+
+(define (test-runner-null)
+ (let ((r (%make-test-runner))
+ (dummy-1 (λ (_) #f))
+ (dummy-3 (λ (_ __ ___) #f)))
+ (test-runner-reset r)
+
+ (test-runner-on-bad-count! r dummy-3)
+ (test-runner-on-bad-end-name! r dummy-3)
+ (test-runner-on-final! r dummy-1)
+ (test-runner-on-group-begin! r dummy-3)
+ (test-runner-on-group-end! r dummy-1)
+ (test-runner-on-test-begin! r dummy-1)
+ (test-runner-on-test-end! r dummy-1)
+
+ (test-runner-run-list! r (make-parameter #f))
+ r))
+
+
+;;;
+;;; Test groups and paths
+;;;
+(define-record-type <group>
+ (make-group name count executed-count installed-runner? previous-skip-list)
+ group?
+ (name group-name)
+ (count group-count)
+ (executed-count group-executed-count group-executed-count!)
+ (installed-runner? group-installed-runner?)
+ (previous-skip-list group-previous-skip-list))
+
+(define (increment-executed-count r)
+ "Increment executed count of the first group."
+ (let ((groups (test-runner-groups r)))
+ (unless (null? groups)
+ (let ((group (car groups)))
+ (group-executed-count! group
+ (1+ (group-executed-count group)))))))
+
+(define* (test-begin suite-name #:optional count)
+ "Enter a new test group."
+ (let* ((r (test-runner-current))
+ (r install? (if r
+ (values r #f)
+ (values (test-runner-create) #t)))
+ (group (make-group suite-name
+ count
+ 0
+ install?
+ (test-runner-skip-list r))))
+ (when install?
+ (test-runner-current r))
+
+ (test-runner-test-name! r suite-name)
+ (test-runner-groups! r (cons group (test-runner-groups r)))
+ ;; Per-strict reading of SRFI-64, -group-stack is required to be
+ ;; non-copying, hence non-computed. So duplicate the information already
+ ;; present in -groups here.
+ (test-runner-group-stack! r (cons suite-name (test-runner-group-stack r)))
+
+ ((test-runner-on-group-begin r) r suite-name count)))
+
+(define* (test-end #:optional suite-name)
+ "Leave the current test group."
+ (let* ((r (test-runner-current))
+ (group (car (test-runner-groups r))))
+
+ (let ((begin-name (car (test-runner-group-stack r)))
+ (end-name suite-name))
+ (when (and end-name (not (string=? begin-name end-name)))
+ ((test-runner-on-bad-end-name r) r begin-name end-name)
+ (raise-exception (make-bad-end-name begin-name end-name))))
+
+ (let ((expected-count (group-count group))
+ (actual-count (group-executed-count group)))
+ (when (and expected-count (not (= expected-count actual-count)))
+ ((test-runner-on-bad-count r) r actual-count expected-count)))
+
+ ((test-runner-on-group-end r) r)
+
+ (test-runner-groups! r (cdr (test-runner-groups r)))
+ (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+ (test-runner-skip-list! r (group-previous-skip-list group))
+
+ (if (null? (test-runner-group-stack r))
+ ((test-runner-on-final r) r)
+ (increment-executed-count r))
+
+ (when (group-installed-runner? group)
+ (test-runner-current #f))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ "Execute @var{decl-or-expr ...} in a named test group. The whole group is
+skipped if it matches an active test-skip."
+ ((_ suite-name decl-or-expr ...)
+ (let ((r (test-runner-current))
+ (name suite-name))
+ ;; Since test-runner stores skip state, if we do not have test-runner,
+ ;; the test cannot be on skip list (it does not exist).
+ (when (or (not r)
+ (begin
+ ;; Specifiers are using -test-name, so we need to do this
+ ;; here and not rely on test-begin.
+ (test-runner-test-name! r name)
+ (not (should-skip?))))
+ (dynamic-wind
+ (λ () (test-begin name))
+ (λ () decl-or-expr ...)
+ (λ () (test-end name))))))))
+
+
+;;;
+;;; Handling set-up and cleanup
+;;;
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ "Execute each of the @var{decl-or-expr} forms in order, and then execute
+the @var{cleanup-form}. The latter shall be executed even if one of a
+@var{decl-or-expr} forms raises an exception."
+ ((_ suite-name decl-or-expr ... cleanup-form)
+ (dynamic-wind
+ (λ () #t)
+ (λ () (test-group suite-name decl-or-expr ...))
+ (λ () cleanup-form)))))
+
+
+;;;
+;;; Simple test-cases
+;;;
+(define (syntax->source-properties form)
+ "Extract properties of syntax @var{form} and return them as a alist with
+keys compatible with Guile's SRFI-64 implementation."
+ (let* ((source (syntax-source form))
+ (file (and=> source (cut assq-ref <> 'filename)))
+ (line (and=> source (cut assq-ref <> 'line)))
+ ;; I do not care about column. Tests are not nested enough.
+ (file-alist (if file
+ `((source-file . ,file))
+ '()))
+ (line-alist (if line
+ `((source-line . ,(1+ line))) ; 1st line should be 1.
+ '())))
+ (datum->syntax form
+ `((source-form . ,(syntax->datum form))
+ ,@file-alist
+ ,@line-alist))))
+
+(define (preliminary-result-kind! r fail? skip?)
+ "Set result-kind before the test was run based on @var{fail?} and
+@var{skip?}."
+ (test-result-set! r 'result-kind (cond
+ ;; I think this order is stupid, but it is
+ ;; what SRFI demands.
+ (fail? 'xfail)
+ (skip? 'skip)
+ (else #f))))
+
+(define (final-result-kind! r match? fail-expected?)
+ "Set the final result-kind based on @var{match?} and @var{fail-expected?}."
+ (test-result-set! r 'result-kind (cond ((and match? fail-expected?)
+ 'xpass)
+ (match?
+ 'pass)
+ (fail-expected?
+ 'xfail)
+ (else
+ 'fail))))
+
+(define (fail-on-exception thunk)
+ "Run the thunk and return the result. If exception occurs, record it and
+return @code{#f}."
+ (with-exception-handler
+ (λ (exc)
+ (test-result-set! (test-runner-current) 'actual-error exc)
+ #f)
+ (λ () (thunk))
+ #:unwind? #t))
+
+(define (increment-test-count r)
+ "Increment the test count for the current 'result-kind."
+ (let* ((kind (test-result-kind r))
+ (counts (test-runner-counts r))
+ (c (or (assq-ref counts kind) 0)))
+ (test-runner-counts! r (assq-set! counts kind (1+ c)))))
+
+(define (test-thunk test-name properties thunk)
+ "Run test @var{thunk} while taking into account currently active skip list
+and such. The result alist is initially set to @var{properties}, however
+@var{thunk} is expected to make additions (actual, expected values, ...).
+
+@var{thunk} must return @code{#f} to indicate test failure. Otherwise the
+test is considered successful."
+ (let ((r (test-runner-current)))
+ ;; Since skip checks are using -test-name, set it first.
+ (test-runner-test-name! r (or test-name ""))
+ (test-runner-result-alist! r properties)
+
+ (let ((fail? (should-fail?))
+ (run? (should-run?))
+ (skip? (should-skip?)))
+ (preliminary-result-kind! r fail? skip?)
+ ((test-runner-on-test-begin r) r)
+ (when run?
+ (if skip?
+ (test-result-set! r 'result-kind 'skip)
+ (begin
+ (final-result-kind! r (fail-on-exception thunk) fail?)
+ (increment-executed-count r))))
+ ((test-runner-on-test-end r) r)
+ (increment-test-count r))))
+
+(define-syntax %test-assert
+ (λ (x)
+ (syntax-case x ()
+ ((_ syn test-name expression)
+ #`(test-thunk (let () test-name)
+ '#,(syntax->source-properties #'syn)
+ (λ ()
+ (let ((r (test-runner-current))
+ (a (let () expression)))
+ (test-result-set! r 'actual-value a)
+ a)))))))
+
+(define-syntax test-assert
+ (λ (x)
+ (syntax-case x ()
+ ((_ test-name expression)
+ #`(%test-assert #,x test-name expression))
+ ((_ expression)
+ #`(%test-assert #,x #f expression)))))
+(set-documentation! 'test-assert
+ "@defspec test-assert test-name expression
+@defspecx test-assert expression
+Evaluate the @var{expression}, the test passes if the result is true.
+
+@var{test-name} and @var{expression} are evaluated just once. It is an error
+to invoke @code{test-assert} if there is no current test runner.
+
+@end defspec")
+
+(define-syntax %%test-2
+ (λ (x)
+ (syntax-case x ()
+ ((_ syn test-proc test-name expected test-expr)
+ #`(test-thunk (let () test-name)
+ '#,(syntax->source-properties #'syn)
+ (λ ()
+ (let ((r (test-runner-current))
+ (e (let () expected))
+ (a (let () test-expr)))
+ (test-result-set! r 'expected-value e)
+ (test-result-set! r 'actual-value a)
+ (test-proc e a))))))))
+
+(define-syntax %test-2
+ (syntax-rules ()
+ ((_ name test-proc)
+ (define-syntax name
+ (λ (x)
+ (syntax-case x ()
+ ((_ test-name expected test-expr)
+ #`(%%test-2 #,x test-proc test-name expected test-expr))
+ ((_ expected test-expr)
+ #`(%%test-2 #,x test-proc #f expected test-expr))))))))
+
+(%test-2 test-eq eq?)
+(%test-2 test-eqv eqv?)
+(%test-2 test-equal equal?)
+
+(set-documentation! 'test-eq
+ "@defspec test-eq test-name expected test-expr
+@defspecx test-eq expected test-expr
+Test whether result of @var{test-expr} matches @var{expected} using
+@code{eq?}.
+
+@end defspec")
+(set-documentation! 'test-eqv
+ "@defspec test-eqv test-name expected test-expr
+@defspecx test-eqv expected test-expr
+Test whether result of @var{test-expr} matches @var{expected} using
+@code{eqv?}.
+
+@end defspec")
+(set-documentation! 'test-equal
+ "@defspec test-equal test-name expected test-expr
+@defspecx test-equal expected test-expr
+Test whether result of @var{test-expr} matches @var{expected} using
+@code{equal?}.
+
+@end defspec")
+
+(define (within-epsilon ε)
+ (λ (expected actual)
+ (and (>= actual (- expected ε))
+ (<= actual (+ expected ε)))))
+
+(define-syntax %test-approximate
+ (λ (x)
+ (syntax-case x ()
+ ((_ syn test-name expected test-expr error)
+ #`(test-thunk (let () test-name)
+ '#,(syntax->source-properties #'syn)
+ (λ ()
+ (let ((r (test-runner-current))
+ (e (let () expected))
+ (a (let () test-expr))
+ (ε (let () error)))
+ (test-result-set! r 'expected-value e)
+ (test-result-set! r 'actual-value a)
+ (test-result-set! r 'epsilon ε)
+ ((within-epsilon ε) e a))))))))
+
+(define-syntax test-approximate
+ (λ (x)
+ (syntax-case x ()
+ ((_ test-name expected test-expr error)
+ #`(%test-approximate #,x test-name expected test-expr error))
+ ((_ expected test-expr error)
+ #`(%test-approximate #,x #f expected test-expr error)))))
+(set-documentation! 'test-approximate
+ "@defspec test-approximate test-name expected test-expr error
+@defspecx test-approximate expected test-expr error
+Test whether result of @var{test-expr} is within @var{error} of
+@var{expected}.
+
+@end defspec")
+
+(define-syntax %test-error
+ (λ (x)
+ (syntax-case x ()
+ ((_ syn test-name error-type test-expr)
+ #`(test-thunk (let () test-name)
+ '#,(syntax->source-properties #'syn)
+ (λ ()
+ (let ((r (test-runner-current))
+ (e-type (let () error-type)))
+ (test-result-set! r 'expected-error e-type)
+ (with-exception-handler
+ (λ (exc)
+ (test-result-set! r 'actual-error exc)
+ (match e-type
+ (#t #t)
+ (#f #f)
+ ((? symbol? sym)
+ (eq? sym (exception-kind exc)))
+ ((? procedure? proc)
+ (proc exc))
+ ((? exception-type? exc-type)
+ ((exception-predicate exc-type) exc))))
+ (λ ()
+ test-expr
+ (not e-type))
+ #:unwind? #t))))))))
+
+(define-syntax test-error
+ (λ (x)
+ (syntax-case x ()
+ ((_ test-name error-type test-expr)
+ #`(%test-error #,x test-name error-type test-expr))
+ ((_ error-type test-expr)
+ #`(%test-error #,x #f error-type test-expr))
+ ((_ test-expr)
+ #`(%test-error #,x #f #t test-expr)))))
+(set-documentation! 'test-error
+ "@defspec test-error test-name error-type test-expr
+@defspecx test-error error-type test-expr
+@defspecx test-error test-expr
+Evaluating @var{test-expr} is expected to signal an error. The kind of error
+is indicated by @var{error-type}. It is always evaluated (even when no
+exception is raised) and can be one of the following.
+
+@table @code
+@item #t
+Per specification, this matches any exception.
+
+@item #f
+Pass if no exception is raised.
+
+@item symbol?
+Symbols can be used to match against exceptions created using
+@code{throw} and @code{error}.
+
+@item procedure?
+The exception object is passed to the predicate procedure. Example
+would be @code{external-error?}.
+
+@item exception-type?
+Exception type like for example @code{&external-error}.
+
+@end table
+
+@end defspec")
+
+
+;;;
+;;; Testing syntax
+;;;
+(define (test-read-eval-string string)
+ "Parse the @var{string} (using @code{read}), evaluate and return the
+result.
+
+An error is signaled if there are unread characters after the @code{read} is
+done."
+ (with-input-from-string string
+ (λ ()
+ (let ((exp (read)))
+ (unless (eof-object? (read-char))
+ (error "read did not consume whole string"))
+ (eval exp (current-module))))))
+
+
+;;;
+;;; Running specific tests with a specified runner
+;;;
+(define-syntax test-with-runner
+ (syntax-rules ()
+ "Execute each @var{decl-or-expr} in order in a context where the current
+test-runner is @var{runner}."
+ ((_ runner decl-or-expr ...)
+ (parameterize ((test-runner-current runner))
+ #t
+ decl-or-expr ...))))
+
+(define (should-run?)
+ "Should current test be considered for execution according to currently
+active run list?"
+ (let ((run-list ((test-runner-run-list (test-runner-current)))))
+ (if run-list
+ (any-specifier-matches? run-list)
+ #t)))
+
+(define test-apply
+ (match-lambda*
+ (((? test-runner? r) specifiers ... thunk)
+ (test-with-runner r
+ (parameterize (((test-runner-run-list r)
+ (if (null? specifiers)
+ #f
+ (map obj->specifier specifiers))))
+ (thunk))))
+ ((specifiers ... thunk)
+ (apply test-apply
+ (or (test-runner-current)
+ (test-runner-create))
+ `(,@specifiers ,thunk)))))
+(set-documentation! 'test-apply
+ "@defunx test-apply runner specifier ... procedure
+@defunx test-apply specifier ... procedure
+
+Call @var{procedure} with no arguments using the specified @var{runner} as the
+current test-runner. If runner is omitted, then @code{(test-runner-current)}
+is used. If there is no current runner, one is created as in
+@code{test-begin}. If one or more @var{specifiers} are listed then only tests
+matching the @var{specifiers} are executed. A specifier has the same form as
+one used for @code{test-skip}. A test is executed if it matches any of the
+specifiers in the @code{test-apply} and does not match any active
+@code{test-skip} specifiers.")
+
+
+;;;
+;;; Additional functionality not covered by the SRFI.
+;;;
+
+(define %define-test-property 'srfi-64-extra/proc-for-test)
+
+(define-syntax define-test
+ (λ (x)
+ (syntax-case x ()
+ ((_ name e ...)
+ (let* ((binding-syn
+ (datum->syntax x
+ (string->symbol
+ (string-append "test-procedure-"
+ (syntax->datum #'name))))))
+ #`(begin
+ (define (#,binding-syn)
+ (test-begin name)
+ e ...
+ (test-end name))
+ (set-procedure-property! #,binding-syn
+ %define-test-property #t)))))))
+(set-documentation! 'define-test
+ "@defspec define-test name form ...
+Introduce a top-level procedure (using @code{define}) with body equivalent to
+
+@lisp
+(test-begin @var{name})
+@var{form ...}
+(test-end @var{name})
+@end lisp
+
+Due to the procedure name being derived from @var{name}, the @var{name} should
+be unique per-module.
+
+The procedure has @code{%define-test-property} procedure property set to
+@code{#t}. This can be used by test driver to discover all test procedures in
+the module.
+
+@end defspec")
+
+(define (test-procedure? obj)
+ "Return whether @var{obj} is a procedure defined by define-test."
+ (and (procedure? obj)
+ (procedure-property obj %define-test-property)))
+
+(define-exception-type &bad-end-name &programming-error
+ make-bad-end-name bad-end-name?
+ (begin-name bad-end-name-begin-name)
+ (end-name bad-end-name-end-name))
+(set-documentation! '&bad-end-name
+ "Exception type raised when @var{suite-name} in @code{test-end} differs from
+matching @code{test-begin}.")
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
deleted file mode 100644
index cdaab140f..000000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1044 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;; Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
-;;
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-;;
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-;;
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-(cond-expand
- (chicken
- (require-extension syntax-case))
- (guile-2
- (use-modules (srfi srfi-9)
- ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
- ;; with either Guile's native exceptions or R6RS exceptions.
- ;;(srfi srfi-34) (srfi srfi-35)
- (srfi srfi-39)))
- (guile
- (use-modules (ice-9 syncase) (srfi srfi-9)
- ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
- (srfi srfi-39)))
- (sisc
- (require-extension (srfi 9 34 35 39)))
- (kawa
- (module-compile-options warn-undefined-variable: #t
- warn-invoke-unknown-method: #t)
- (provide 'srfi-64)
- (provide 'testing)
- (require 'srfi-34)
- (require 'srfi-35))
- (else ()
- ))
-
-(cond-expand
- (kawa
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export test-begin . other-names)
- (module-export %test-begin . other-names)))))
- (else
- (define-syntax %test-export
- (syntax-rules ()
- ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index setter getter) ...)
- (define-record-type test-runner
- (alloc)
- runner?
- (name setter getter) ...)))))
- (else
- (define %test-runner-cookie (list "test-runner"))
- (define-syntax %test-record-define
- (syntax-rules ()
- ((%test-record-define alloc runner? (name index getter setter) ...)
- (begin
- (define (runner? obj)
- (and (vector? obj)
- (> (vector-length obj) 1)
- (eq (vector-ref obj 0) %test-runner-cookie)))
- (define (alloc)
- (let ((runner (make-vector 23)))
- (vector-set! runner 0 %test-runner-cookie)
- runner))
- (begin
- (define (getter runner)
- (vector-ref runner index)) ...)
- (begin
- (define (setter runner value)
- (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
- (test-result-alist! runner '())
- (test-runner-pass-count! runner 0)
- (test-runner-fail-count! runner 0)
- (test-runner-xpass-count! runner 0)
- (test-runner-xfail-count! runner 0)
- (test-runner-skip-count! runner 0)
- (%test-runner-total-count! runner 0)
- (%test-runner-count-list! runner '())
- (%test-runner-run-list! runner #t)
- (%test-runner-skip-list! runner '())
- (%test-runner-fail-list! runner '())
- (%test-runner-skip-save! runner '())
- (%test-runner-fail-save! runner '())
- (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
- (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner (lambda (runner name count) #f))
- (test-runner-on-group-end! runner %test-null-callback)
- (test-runner-on-final! runner %test-null-callback)
- (test-runner-on-test-begin! runner %test-null-callback)
- (test-runner-on-test-end! runner %test-null-callback)
- (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
- (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
- runner))
-
-;; Not part of the specification. FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
- (let ((runner (%test-runner-alloc)))
- (test-runner-reset runner)
- (test-runner-on-group-begin! runner test-on-group-begin-simple)
- (test-runner-on-group-end! runner test-on-group-end-simple)
- (test-runner-on-final! runner test-on-final-simple)
- (test-runner-on-test-begin! runner test-on-test-begin-simple)
- (test-runner-on-test-end! runner test-on-test-end-simple)
- (test-runner-on-bad-count! runner test-on-bad-count-simple)
- (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
- runner))
-
-(cond-expand
- (srfi-39
- (define test-runner-current (make-parameter #f))
- (define test-runner-factory (make-parameter test-runner-simple)))
- (else
- (define %test-runner-current #f)
- (define-syntax test-runner-current
- (syntax-rules ()
- ((test-runner-current)
- %test-runner-current)
- ((test-runner-current runner)
- (set! %test-runner-current runner))))
- (define %test-runner-factory test-runner-simple)
- (define-syntax test-runner-factory
- (syntax-rules ()
- ((test-runner-factory)
- %test-runner-factory)
- ((test-runner-factory runner)
- (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
- (let ((r (test-runner-current)))
- (if (not r)
- (cond-expand
- (srfi-23 (error "test-runner not initialized - test-begin missing?"))
- (else #t)))
- r))
-
-(define (%test-specifier-matches spec runner)
- (spec runner))
-
-(define (test-runner-create)
- ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
- (let ((result #f))
- (let loop ((l list))
- (cond ((null? l) result)
- (else
- (if (%test-specifier-matches (car l) runner)
- (set! result #t))
- (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
- (let ((run (%test-runner-run-list runner)))
- (cond ((or
- (not (or (eqv? run #t)
- (%test-any-specifier-matches run runner)))
- (%test-any-specifier-matches
- (%test-runner-skip-list runner)
- runner))
- (test-result-set! runner 'result-kind 'skip)
- #f)
- ((%test-any-specifier-matches
- (%test-runner-fail-list runner)
- runner)
- (test-result-set! runner 'result-kind 'xfail)
- 'xfail)
- (else #t))))
-
-(define (%test-begin suite-name count)
- (if (not (test-runner-current))
- (let ((r (test-runner-create)))
- (test-runner-current r)
- (test-runner-on-final! r
- (let ((old-final (test-runner-on-final r)))
- (lambda (r) (old-final r) (test-runner-current #f))))))
- (let ((runner (test-runner-current)))
- ((test-runner-on-group-begin runner) runner suite-name count)
- (%test-runner-skip-save! runner
- (cons (%test-runner-skip-list runner)
- (%test-runner-skip-save runner)))
- (%test-runner-fail-save! runner
- (cons (%test-runner-fail-list runner)
- (%test-runner-fail-save runner)))
- (%test-runner-count-list! runner
- (cons (cons (%test-runner-total-count runner)
- count)
- (%test-runner-count-list runner)))
- (test-runner-group-stack! runner (cons suite-name
- (test-runner-group-stack runner)))))
-(cond-expand
- (kawa
- ;; Kawa has test-begin built in, implemented as:
- ;; (begin
- ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
- ;; (%test-begin suite-name [count]))
- ;; This puts test-begin but only test-begin in the default environment.,
- ;; which makes normal test suites loadable without non-portable commands.
- )
- (else
- (define-syntax test-begin
- (syntax-rules ()
- ((test-begin suite-name)
- (%test-begin suite-name #f))
- ((test-begin suite-name count)
- (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
- (if (null? (test-runner-group-stack runner))
- (begin
- (display "%%%% Starting test ")
- (display suite-name)
- (if test-log-to-file
- (let* ((log-file-name
- (if (string? test-log-to-file) test-log-to-file
- (string-append suite-name ".log")))
- (log-file
- (cond-expand (mzscheme
- (open-output-file log-file-name
'truncate/replace))
- (else (open-output-file log-file-name)))))
- (display "%%%% Starting test " log-file)
- (display suite-name log-file)
- (newline log-file)
- (test-runner-aux-value! runner log-file)
- (display " (Writing full log to \"")
- (display log-file-name)
- (display "\")")))
- (newline)))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group begin: " log)
- (display suite-name log)
- (newline log))))
- #f)
-
-(define (test-on-group-end-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (begin
- (display "Group end: " log)
- (display (car (test-runner-group-stack runner)) log)
- (newline log))))
- #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
- (display "*** Total number of tests was " port)
- (display count port)
- (display " but should be " port)
- (display expected-count port)
- (display ". ***" port)
- (newline port)
- (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
- (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
- (%test-on-bad-count-write runner count expected-count (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
- (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
- " does not match test-begin " end-name)))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
-
-
-(define (%test-final-report1 value label port)
- (if (> value 0)
- (begin
- (display label port)
- (display value port)
- (newline port))))
-
-(define (%test-final-report-simple runner port)
- (%test-final-report1 (test-runner-pass-count runner)
- "# of expected passes " port)
- (%test-final-report1 (test-runner-xfail-count runner)
- "# of expected failures " port)
- (%test-final-report1 (test-runner-xpass-count runner)
- "# of unexpected successes " port)
- (%test-final-report1 (test-runner-fail-count runner)
- "# of unexpected failures " port)
- (%test-final-report1 (test-runner-skip-count runner)
- "# of skipped tests " port))
-
-(define (test-on-final-simple runner)
- (%test-final-report-simple runner (current-output-port))
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
- (let* ((line-info (test-result-alist runner))
- (source-file (assq 'source-file line-info))
- (source-line (assq 'source-line line-info))
- (file (if source-file (cdr source-file) "")))
- (if source-line
- (string-append file ":"
- (number->string (cdr source-line)) ": ")
- "")))
-
-(define (%test-end suite-name line-info)
- (let* ((r (test-runner-get))
- (groups (test-runner-group-stack r))
- (line (%test-format-line r)))
- (test-result-alist! r line-info)
- (if (null? groups)
- (let ((msg (string-append line "test-end not in a group")))
- (cond-expand
- (srfi-23 (error msg))
- (else (display msg) (newline)))))
- (if (and suite-name (not (equal? suite-name (car groups))))
- ((test-runner-on-bad-end-name r) r suite-name (car groups)))
- (let* ((count-list (%test-runner-count-list r))
- (expected-count (cdar count-list))
- (saved-count (caar count-list))
- (group-count (- (%test-runner-total-count r) saved-count)))
- (if (and expected-count
- (not (= expected-count group-count)))
- ((test-runner-on-bad-count r) r group-count expected-count))
- ((test-runner-on-group-end r) r)
- (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
- (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
- (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
- (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
- (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
- (%test-runner-count-list! r (cdr count-list))
- (if (null? (test-runner-group-stack r))
- ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
- (syntax-rules ()
- ((test-group suite-name . body)
- (let ((r (test-runner-current)))
- ;; Ideally should also set line-number, if available.
- (test-result-alist! r (list (cons 'test-name suite-name)))
- (if (%test-should-execute r)
- (dynamic-wind
- (lambda () (test-begin suite-name))
- (lambda () . body)
- (lambda () (test-end suite-name))))))))
-
-(define-syntax test-group-with-cleanup
- (syntax-rules ()
- ((test-group-with-cleanup suite-name form cleanup-form)
- (test-group suite-name
- (dynamic-wind
- (lambda () #f)
- (lambda () form)
- (lambda () cleanup-form))))
- ((test-group-with-cleanup suite-name cleanup-form)
- (test-group-with-cleanup suite-name #f cleanup-form))
- ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
- (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
- (if (output-port? log)
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (source-form (assq 'source-form results))
- (test-name (assq 'test-name results)))
- (display "Test begin:" log)
- (newline log)
- (if test-name (%test-write-result1 test-name log))
- (if source-file (%test-write-result1 source-file log))
- (if source-line (%test-write-result1 source-line log))
- (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
- (syntax-rules ()
- ((test-result-ref runner pname)
- (test-result-ref runner pname #f))
- ((test-result-ref runner pname default)
- (let ((p (assq pname (test-result-alist runner))))
- (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
- (let ((log (test-runner-aux-value runner))
- (kind (test-result-ref runner 'result-kind)))
- (if (memq kind '(fail xpass))
- (let* ((results (test-result-alist runner))
- (source-file (assq 'source-file results))
- (source-line (assq 'source-line results))
- (test-name (assq 'test-name results)))
- (if (or source-file source-line)
- (begin
- (if source-file (display (cdr source-file)))
- (display ":")
- (if source-line (display (cdr source-line)))
- (display ": ")))
- (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
- (if test-name
- (begin
- (display " ")
- (display (cdr test-name))))
- (newline)))
- (if (output-port? log)
- (begin
- (display "Test end:" log)
- (newline log)
- (let loop ((list (test-result-alist runner)))
- (if (pair? list)
- (let ((pair (car list)))
- ;; Write out properties not written out by on-test-begin.
- (if (not (memq (car pair)
- '(test-name source-file source-line
source-form)))
- (%test-write-result1 pair log))
- (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
- (display " " port)
- (display (car pair) port)
- (display ": " port)
- (write (cdr pair) port)
- (newline port))
-
-(define (test-result-set! runner pname value)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (set-cdr! p value)
- (test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
- (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
- (let* ((alist (test-result-alist runner))
- (p (assq pname alist)))
- (if p
- (test-result-alist! runner
- (let loop ((r alist))
- (if (eq? r p) (cdr r)
- (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
- (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
- (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
- (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
- (let* ((r (test-runner-get))
- (result-kind (test-result-kind r)))
- (case result-kind
- ((pass)
- (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
- ((fail)
- (test-runner-fail-count! r (+ 1 (test-runner-fail-count r))))
- ((xpass)
- (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
- ((xfail)
- (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
- (else
- (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
- (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
- ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (catch #t
- (lambda () test-expression)
- (lambda (key . args)
- (test-result-set! (test-runner-current) 'actual-error
- (cons key args))
- #f))))))
- (kawa
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (try-catch test-expression
- (ex <java.lang.Throwable>
- (test-result-set! (test-runner-current) 'actual-error ex)
- #f))))))
- (srfi-34
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (guard (err (else #f)) test-expression)))))
- (chicken
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- (condition-case test-expression (ex () #f))))))
- (else
- (define-syntax %test-evaluate-with-catch
- (syntax-rules ()
- ((%test-evaluate-with-catch test-expression)
- test-expression)))))
-
-(cond-expand
- ((or kawa mzscheme)
- (cond-expand
- (mzscheme
- (define-for-syntax (%test-syntax-file form)
- (let ((source (syntax-source form)))
- (cond ((string? source) file)
- ((path? source) (path->string source))
- (else #f)))))
- (kawa
- (define (%test-syntax-file form)
- (syntax-source form))))
- (define (%test-source-line2 form)
- (let* ((line (syntax-line form))
- (file (%test-syntax-file form))
- (line-pair (if line (list (cons 'source-line line)) '())))
- (cons (cons 'source-form (syntax-object->datum form))
- (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
- (define (%test-source-line2 form)
- (let* ((src-props (syntax-source form))
- (file (and src-props (assq-ref src-props 'filename)))
- (line (and src-props (assq-ref src-props 'line)))
- (file-alist (if file
- `((source-file . ,file))
- '()))
- (line-alist (if line
- `((source-line . ,(+ line 1)))
- '())))
- (datum->syntax (syntax here)
- `((source-form . ,(syntax->datum form))
- ,@file-alist
- ,@line-alist)))))
- (else
- (define (%test-source-line2 form)
- '())))
-
-(define (%test-on-test-begin r)
- (%test-should-execute r)
- ((test-runner-on-test-begin r) r)
- (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
- (test-result-set! r 'result-kind
- (if (eq? (test-result-ref r 'result-kind) 'xfail)
- (if result 'xpass 'xfail)
- (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
- (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
- (syntax-rules ()
- ((%test-comp2body r comp expected expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ((exp expected))
- (test-result-set! r 'expected-value exp)
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r (comp exp res)))))
- (%test-report-result)))))
-
-(define (%test-approximate= error)
- (lambda (value expected)
- (let ((rval (real-part value))
- (ival (imag-part value))
- (rexp (real-part expected))
- (iexp (imag-part expected)))
- (and (>= rval (- rexp error))
- (>= ival (- iexp error))
- (<= rval (+ rexp error))
- (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
- (syntax-rules ()
- ((%test-comp1body r expr)
- (let ()
- (if (%test-on-test-begin r)
- (let ()
- (let ((res (%test-evaluate-with-catch expr)))
- (test-result-set! r 'actual-value res)
- (%test-on-test-end r res))))
- (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
- ;; Should be made to work for any Scheme with syntax-case
- ;; However, I haven't gotten the quoting working. FIXME.
- (define-syntax test-end
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac suite-name) line)
- (syntax
- (%test-end suite-name line)))
- (((mac) line)
- (syntax
- (%test-end #f line))))))
- (define-syntax test-assert
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp1body r expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp1body r expr)))))))
- (define (%test-comp2 comp x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
- (((mac tname expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r comp expected expr))))
- (((mac expected expr) line comp)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r comp expected expr))))))
- (define-syntax test-eqv
- (lambda (x) (%test-comp2 (syntax eqv?) x)))
- (define-syntax test-eq
- (lambda (x) (%test-comp2 (syntax eq?) x)))
- (define-syntax test-equal
- (lambda (x) (%test-comp2 (syntax equal?) x)))
- (define-syntax test-approximate ;; FIXME - needed for non-Kawa
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname expected expr error) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-comp2body r (%test-approximate= error) expected expr))))
- (((mac expected expr error) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
- (define-syntax test-end
- (syntax-rules ()
- ((test-end)
- (%test-end #f '()))
- ((test-end suite-name)
- (%test-end suite-name '()))))
- (define-syntax test-assert
- (syntax-rules ()
- ((test-assert tname test-expression)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r '((test-name . tname)))
- (%test-comp1body r test-expression)))
- ((test-assert test-expression)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp1body r test-expression)))))
- (define-syntax %test-comp2
- (syntax-rules ()
- ((%test-comp2 comp tname expected expr)
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (list (cons 'test-name tname)))
- (%test-comp2body r comp expected expr)))
- ((%test-comp2 comp expected expr)
- (let* ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-comp2body r comp expected expr)))))
- (define-syntax test-equal
- (syntax-rules ()
- ((test-equal . rest)
- (%test-comp2 equal? . rest))))
- (define-syntax test-eqv
- (syntax-rules ()
- ((test-eqv . rest)
- (%test-comp2 eqv? . rest))))
- (define-syntax test-eq
- (syntax-rules ()
- ((test-eq . rest)
- (%test-comp2 eq? . rest))))
- (define-syntax test-approximate
- (syntax-rules ()
- ((test-approximate tname expected expr error)
- (%test-comp2 (%test-approximate= error) tname expected expr))
- ((test-approximate expected expr error)
- (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (cond ((%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (catch #t
- (lambda ()
- (test-result-set! r 'actual-value expr)
- #f)
- (lambda (key . args)
- ;; TODO: decide how to specify expected
- ;; error types for Guile.
- (test-result-set! r 'actual-error
- (cons key args))
- #t)))
- (%test-report-result))))))))
- (mzscheme
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
- (let ()
- (test-result-set! r 'actual-value
expr)
- #f)))))))
- (chicken
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r #t expr)
- (cond ((%test-on-test-begin r)
- (test-result-set! r 'expected-error #t)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- #t)))
- (%test-report-result))))
- ((%test-error r etype expr)
- (if (%test-on-test-begin r)
- (let ((et etype))
- (test-result-set! r 'expected-error et)
- (%test-on-test-end r
- (try-catch
- (let ()
- (test-result-set! r 'actual-value expr)
- #f)
- (ex <java.lang.Throwable>
- (test-result-set! r 'actual-error ex)
- (cond ((and (instance? et
<gnu.bytecode.ClassType>)
-
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
- (instance? ex et))
- (else #t)))))
- (%test-report-result)))))))
- ((and srfi-34 srfi-35)
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex ((condition-type? etype)
- (and (condition? ex) (condition-has-type? ex etype)))
- ((procedure? etype)
- (etype ex))
- ((equal? etype #t)
- #t)
- (else #t))
- expr #f))))))
- (srfi-34
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
- (define-syntax %test-error
- (syntax-rules ()
- ((%test-error r etype expr)
- (begin
- ((test-runner-on-test-begin r) r)
- (test-result-set! r 'result-kind 'skip)
- (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
- (define-syntax test-error
- (lambda (x)
- (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
- (((mac tname etype expr) line)
- (syntax
- (let* ((r (test-runner-get))
- (name tname))
- (test-result-alist! r (cons (cons 'test-name tname) line))
- (%test-error r etype expr))))
- (((mac etype expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r etype expr))))
- (((mac expr) line)
- (syntax
- (let* ((r (test-runner-get)))
- (test-result-alist! r line)
- (%test-error r #t expr))))))))
- (else
- (define-syntax test-error
- (syntax-rules ()
- ((test-error name etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r `((test-name . ,name)))
- (%test-error r etype expr)))
- ((test-error etype expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r etype expr)))
- ((test-error expr)
- (let ((r (test-runner-get)))
- (test-result-alist! r '())
- (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
- (if (test-runner? first)
- (test-with-runner first (apply test-apply rest))
- (let ((r (test-runner-current)))
- (if r
- (let ((run-list (%test-runner-run-list r)))
- (cond ((null? rest)
- (%test-runner-run-list! r (reverse run-list))
- (first)) ;; actually apply procedure thunk
- (else
- (%test-runner-run-list!
- r
- (if (eq? run-list #t) (list first) (cons first run-list)))
- (apply test-apply rest)
- (%test-runner-run-list! r run-list))))
- (let ((r (test-runner-create)))
- (test-with-runner r (apply test-apply first rest))
- ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
- (syntax-rules ()
- ((test-with-runner runner form ...)
- (let ((saved-runner (test-runner-current)))
- (dynamic-wind
- (lambda () (test-runner-current runner))
- (lambda () form ...)
- (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
- (let ((i 0))
- (lambda (runner)
- (set! i (+ i 1))
- (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
- (syntax-rules ()
- ((test-match-nth n)
- (test-match-nth n 1))
- ((test-match-nth n count)
- (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
- (lambda (runner)
- (let ((result #t))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if (not ((car l) runner))
- (set! result #f))
- (loop (cdr l))))))))
-
-(define-syntax test-match-all
- (syntax-rules ()
- ((test-match-all pred ...)
- (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
- (lambda (runner)
- (let ((result #f))
- (let loop ((l pred-list))
- (if (null? l)
- result
- (begin
- (if ((car l) runner)
- (set! result #t))
- (loop (cdr l))))))))
-
-(define-syntax test-match-any
- (syntax-rules ()
- ((test-match-any pred ...)
- (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
- (cond ((procedure? specifier) specifier)
- ((integer? specifier) (test-match-nth 1 specifier))
- ((string? specifier) (test-match-name specifier))
- (else
- (error "not a valid test specifier"))))
-
-(define-syntax test-skip
- (syntax-rules ()
- ((test-skip pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-skip-list! runner
- (cons (test-match-all (%test-as-specifier
pred) ...)
- (%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
- (syntax-rules ()
- ((test-expect-fail pred ...)
- (let ((runner (test-runner-get)))
- (%test-runner-fail-list! runner
- (cons (test-match-all (%test-as-specifier
pred) ...)
- (%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
- (lambda (runner)
- (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
- (let* ((port (open-input-string string))
- (form (read port)))
- (if (eof-object? (read-char port))
- (cond-expand
- (guile (eval form (current-module)))
- (else (eval form)))
- (cond-expand
- (srfi-23 (error "(not at eof)"))
- (else "error")))))
-
diff --git a/test-suite/tests/srfi-64-test.scm
b/test-suite/tests/srfi-64-test.scm
index ca0b58943..beb5129b7 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -716,7 +716,7 @@
(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))
+ '(("w" "p" "v") () () () () (3 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
@@ -733,7 +733,7 @@
(test-assert "v" #t))))
(test-equal "8.6.2. Simple (form 2) test-apply"
- '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+ '(("w" "p" "v") () () () () (3 0 0 0 0))
(triv-runner
(lambda ()
(test-begin "a")
--
2.46.0