[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/13: Replace SRFI-64 with a new implementation.
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] 01/13: Replace SRFI-64 with a new implementation. |
|
Date: |
Sun, 20 Oct 2024 15:23:21 -0400 (EDT) |
civodul pushed a commit to branch main
in repository guile.
commit ad90f45a8c4fd00add44c214863850a425f787a0
Author: Tomas Volf <~@wolfsden.cz>
AuthorDate: Wed Oct 2 21:27:59 2024 +0200
Replace SRFI-64 with a new implementation.
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.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
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(-)
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")
- [Guile-commits] branch main updated (08e26836f -> faa8ab8a8), Ludovic Courtès, 2024/10/20
- [Guile-commits] 01/13: Replace SRFI-64 with a new implementation.,
Ludovic Courtès <=
- [Guile-commits] 07/13: filesys.c: Fix readlink for ports on Darwin., Ludovic Courtès, 2024/10/20
- [Guile-commits] 05/13: tests: Skip tests of abstract Unix sockets on Darwin., Ludovic Courtès, 2024/10/20
- [Guile-commits] 03/13: Fix typo in dynamic wind documentation., Ludovic Courtès, 2024/10/20
- [Guile-commits] 02/13: Fix gbt command in gdbinit, Ludovic Courtès, 2024/10/20
- [Guile-commits] 04/13: tests: Check TCP_NODELAY for non-zero instead of 1., Ludovic Courtès, 2024/10/20
- [Guile-commits] 10/13: tests: Fix spawn if file not found with Gnulib., Ludovic Courtès, 2024/10/20
- [Guile-commits] 08/13: tests: Skip mkdtemp test for invalid template on Darwin., Ludovic Courtès, 2024/10/20
- [Guile-commits] 06/13: tests: Skip hole-related port tests on Darwin., Ludovic Courtès, 2024/10/20
- [Guile-commits] 11/13: Do not depend on tmpnam in posix.test., Ludovic Courtès, 2024/10/20
- [Guile-commits] 09/13: tests: Fix spawn with #:environment on MacOS., Ludovic Courtès, 2024/10/20