* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
@ 2024-10-02 19:27 Tomas Volf
2024-10-13 20:09 ` Ludovic Courtès
[not found] ` <87o73nrchr.fsf@gnu.org>
0 siblings, 2 replies; 9+ messages in thread
From: Tomas Volf @ 2024-10-02 19:27 UTC (permalink / raw)
To: 73605; +Cc: Tomas Volf, guile-devel
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))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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.")
+
+\f
+;;;
+;;; 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))))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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))
+
+\f
+;;;
+;;; 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))))))))
+
+\f
+;;;
+;;; 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)))))
+
+\f
+;;;
+;;; 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")
+
+\f
+;;;
+;;; 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))))))
+
+\f
+;;;
+;;; 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.")
+
+\f
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 9+ messages in thread* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-02 19:27 bug#73605: [PATCH] Replace SRFI-64 with a new implementation Tomas Volf
@ 2024-10-13 20:09 ` Ludovic Courtès
[not found] ` <87o73nrchr.fsf@gnu.org>
1 sibling, 0 replies; 9+ messages in thread
From: Ludovic Courtès @ 2024-10-13 20:09 UTC (permalink / raw)
To: Tomas Volf; +Cc: Andy Wingo, guile-devel, 73605, Rob Browning
Hi Tomas,
Tomas Volf <~@wolfsden.cz> skribis:
> 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.
Nice work!
Andy, Rob: I’m willing to apply this patch as I think it’s an
improvement over the reference implementation that we currently have,
and whose weaknesses Tomas described at length in
<https://wolfsden.cz/blog/post/state-of-srfi-64.html>. The fact that
this new implementation was successfully tested with the test suite of
Guix (probably the largest SRFI-64 user) is also reassuring to me.
Everyone, please speak up if you object. If there are no objections
within a week or so, I’d like to apply it.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread[parent not found: <87o73nrchr.fsf@gnu.org>]
* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
[not found] ` <87o73nrchr.fsf@gnu.org>
@ 2024-10-20 19:24 ` Ludovic Courtès
2024-10-20 19:25 ` Ludovic Courtès
1 sibling, 0 replies; 9+ messages in thread
From: Ludovic Courtès @ 2024-10-20 19:24 UTC (permalink / raw)
To: Tomas Volf; +Cc: Andy Wingo, 73605-done, guile-devel, Rob Browning
Hi,
Ludovic Courtès <ludo@gnu.org> skribis:
> Tomas Volf <~@wolfsden.cz> skribis:
>
>> 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.
[...]
> Everyone, please speak up if you object. If there are no objections
> within a week or so, I’d like to apply it.
Pushed as ad90f45a8c4fd00add44c214863850a425f787a0, thanks Tomas!
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
[not found] ` <87o73nrchr.fsf@gnu.org>
2024-10-20 19:24 ` Ludovic Courtès
@ 2024-10-20 19:25 ` Ludovic Courtès
2024-10-21 17:35 ` lloda
2024-10-21 20:15 ` Tomas Volf
1 sibling, 2 replies; 9+ messages in thread
From: Ludovic Courtès @ 2024-10-20 19:25 UTC (permalink / raw)
To: Tomas Volf; +Cc: Andy Wingo, 73605, guile-devel, Rob Browning
Tomas, I leave you the satisfaction of closing all the SRFI-64 bugs.
:-)
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-20 19:25 ` Ludovic Courtès
@ 2024-10-21 17:35 ` lloda
2024-10-26 13:21 ` Ludovic Courtès
2024-10-21 20:15 ` Tomas Volf
1 sibling, 1 reply; 9+ messages in thread
From: lloda @ 2024-10-21 17:35 UTC (permalink / raw)
To: 73605; +Cc: Tomas Volf, Ludovic Courtès
I'm pleased to see all these fixes. However, I noticed a few breakages. They come from relying on undocumented behavior, but only using the public interface, so others might be affected. I don't propose to patch them, but perhaps to make a note in NEWS or (for the last two) to add a paragraph in the manual explaining how to achieve the same goal – the reference documentation doesn't have enough examples.
* test-begin and test-end now require strings. The old version accepted symbols.
* test-approximate requires real arguments. The old version accepted complex arguments.
* The exported variable test-log-to-file is gone.
^ permalink raw reply [flat|nested] 9+ messages in thread
* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-21 17:35 ` lloda
@ 2024-10-26 13:21 ` Ludovic Courtès
2024-10-26 14:09 ` Tomas Volf
0 siblings, 1 reply; 9+ messages in thread
From: Ludovic Courtès @ 2024-10-26 13:21 UTC (permalink / raw)
To: lloda; +Cc: Tomas Volf, 73605
Hi,
lloda <lloda@sarc.name> skribis:
> I'm pleased to see all these fixes. However, I noticed a few breakages. They come from relying on undocumented behavior, but only using the public interface, so others might be affected. I don't propose to patch them, but perhaps to make a note in NEWS or (for the last two) to add a paragraph in the manual explaining how to achieve the same goal – the reference documentation doesn't have enough examples.
>
> * test-begin and test-end now require strings. The old version accepted symbols.
> * test-approximate requires real arguments. The old version accepted complex arguments.
> * The exported variable test-log-to-file is gone.
As discussed on IRC, I think we should consider restoring support for
these idioms, whether or not they conform to the reference, in an effort
to minimize breakage (especially since this is slated for a point
release).
WDYT, Tomas?
Ludo’.
^ permalink raw reply [flat|nested] 9+ messages in thread
* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-26 13:21 ` Ludovic Courtès
@ 2024-10-26 14:09 ` Tomas Volf
2024-10-26 18:09 ` lloda
0 siblings, 1 reply; 9+ messages in thread
From: Tomas Volf @ 2024-10-26 14:09 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: lloda, 73605
[-- Attachment #1: Type: text/plain, Size: 3312 bytes --]
Hello,
I was thinking about this and then forgot to reply. Sorry about that.
Ludovic Courtès <ludo@gnu.org> writes:
> Hi,
>
> lloda <lloda@sarc.name> skribis:
>
>> I'm pleased to see all these fixes. However, I noticed a few breakages. They
>> come from relying on undocumented behavior, but only using the public
>> interface, so others might be affected. I don't propose to patch them, but
>> perhaps to make a note in NEWS or (for the last two) to add a paragraph in the
>> manual explaining how to achieve the same goal – the reference documentation
>> doesn't have enough examples.
>>
>> * test-begin and test-end now require strings. The old version accepted symbols.
No problem with this one. Even the specification for test-begin does
note:
> Rationale: In some ways using symbols would be preferable. However, we
> want human-readable names, and standard Scheme does not provide a way
> to include spaces or mixed-case text in literal symbols.
I am just thinking how to express it neatly, maybe something like the
following would work well enough?
--8<---------------cut here---------------start------------->8---
--- a/wolfsden/srfi/srfi-64.scm
+++ b/wolfsden/srfi/srfi-64.scm
@@ -513,6 +513,14 @@ returning new test runner. Defaults to @code{test-runner-simple}.")
((test-runner-on-group-begin r) r suite-name count)))
+(define (%cmp-group-name a b)
+ (match (list a b)
+ (((? string?) (? string?))
+ (string=? a b))
+ (((? symbol?) (? symbol?))
+ (eq? a b))
+ (_ #f)))
+
(define* (test-end #:optional suite-name)
"Leave the current test group."
(let* ((r (test-runner-current))
@@ -520,7 +528,7 @@ returning new test runner. Defaults to @code{test-runner-simple}.")
(let ((begin-name (car (test-runner-group-stack r)))
(end-name suite-name))
- (when (and end-name (not (string=? begin-name end-name)))
+ (when (and end-name (not (%cmp-group-name 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))))
--8<---------------cut here---------------end--------------->8---
Is there more elegant way to express this?
>> * test-approximate requires real arguments. The old version accepted complex arguments.
No objections, since it seems that (imag-part 0) works just fine, I can
basically rewrite it to always consider the input complex, and it will
work.
>> * The exported variable test-log-to-file is gone.
I oppose to restoring this one. When you loaded test file into REPL, it
used to just litter your file system with random test log files created
in whatever the current working directory is. I do not consider that to
be a good behavior.
>
> As discussed on IRC, I think we should consider restoring support for
> these idioms, whether or not they conform to the reference, in an effort
> to minimize breakage (especially since this is slated for a point
> release).
>
> WDYT, Tomas?
Reacted above, I am fine with the first two, oppose to the third one.
I will send a patch for the first two today.
Tomas
--
There are only two hard things in Computer Science:
cache invalidation, naming things and off-by-one errors.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-26 14:09 ` Tomas Volf
@ 2024-10-26 18:09 ` lloda
0 siblings, 0 replies; 9+ messages in thread
From: lloda @ 2024-10-26 18:09 UTC (permalink / raw)
To: Tomas Volf; +Cc: Ludovic Courtès, 73605
> On 26 Oct 2024, at 16:09, Tomas Volf <~@wolfsden.cz> wrote:
>>> * test-approximate requires real arguments. The old version accepted complex arguments.
>
> No objections, since it seems that (imag-part 0) works just fine, I can
> basically rewrite it to always consider the input complex, and it will
> work.
I think just changing within-epsilon to check (<= (magnitude (- expected value)) epsilon) would work.
While looking at this I noticed that 1) the default test runner doesn't print either the computed error or the specified error and 2) test-approximate doesn't store the computed error in the test result (it does store the specified error).
This makes it difficult for a custom test runner to print these things. I think test-approximate should store the computed error and also that these properties should be documented, so user-defined test routines (to compare other types) can use them as well.
>>> * The exported variable test-log-to-file is gone.
>
> I oppose to restoring this one. When you loaded test file into REPL, it
> used to just litter your file system with random test log files created
> in whatever the current working directory is. I do not consider that to
> be a good behavior.
I don't think the variable should be restored. I also think that if the option were to be offered in a different way, not writing files is the better default. However, users who relied on the variable should not lose functionality. Perhaps add an argument to the default runner?
Regards
lloda
^ permalink raw reply [flat|nested] 9+ messages in thread
* bug#73605: [PATCH] Replace SRFI-64 with a new implementation.
2024-10-20 19:25 ` Ludovic Courtès
2024-10-21 17:35 ` lloda
@ 2024-10-21 20:15 ` Tomas Volf
1 sibling, 0 replies; 9+ messages in thread
From: Tomas Volf @ 2024-10-21 20:15 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 73605
[-- Attachment #1: Type: text/plain, Size: 322 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Tomas, I leave you the satisfaction of closing all the SRFI-64 bugs.
> :-)
Thank you for merging the patch, I am off to close the bug reports :)
Tomas
--
There are only two hard things in Computer Science:
cache invalidation, naming things and off-by-one errors.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2024-10-26 18:09 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-10-02 19:27 bug#73605: [PATCH] Replace SRFI-64 with a new implementation Tomas Volf
2024-10-13 20:09 ` Ludovic Courtès
[not found] ` <87o73nrchr.fsf@gnu.org>
2024-10-20 19:24 ` Ludovic Courtès
2024-10-20 19:25 ` Ludovic Courtès
2024-10-21 17:35 ` lloda
2024-10-26 13:21 ` Ludovic Courtès
2024-10-26 14:09 ` Tomas Volf
2024-10-26 18:09 ` lloda
2024-10-21 20:15 ` Tomas Volf
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).