[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Switch to modernized SRFI-64 implementation.
|
From: |
Taylan Ulrich Bayırlı/Kammer |
|
Subject: |
[PATCH] Switch to modernized SRFI-64 implementation. |
|
Date: |
Wed, 02 Sep 2015 12:55:15 +0200 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) |
(I forget the [PATCH] tag sometimes; sorry about inconsistency.)
This patch swaps out our SRFI-64 implementation for the one hosted at:
https://github.com/taylanub/scheme-srfis
The .body.scm files need no changes at all for Guile so keeping them in
sync with upstream should be trivial. The .sld library can also be
trivially converted into Guile format, as seen in the srfi-64.scm file
containing the define-module/import/include boilerplate.
This implementation has a few advantages over the current one:
* Much better maintainability. This hinges on several subjective
points, but I hope for at least some of them to be highly agreeable,
because this is the main advantage.
** The library is split into three main sub-libraries: the test-runner
data type, the default "simple" test runner, and "execution," which
contains the forms with which you write test suites themselves
(without mucking with runners). Source location information resides
in a small fourth sub-library (more such might be added).
** Much less cond-expand clutter. Long live C-M-a/C-M-e!
** Makes use of modern Scheme features instead of trying to be
ultra-portable.
** Overall cleanup of coding style: using modern best-practices and
idioms, being more internally consistent in style, being generally
cleaner in small things like variable naming and whitespace, thus
making the code overall more readable.
*** I use the <foo> naming convention for syntax-rules pattern
variables. I've been doing this for a while and in my experience it
doesn't conflict with record type names, very clearly demarcates
pattern variables in syntax templates (which is important because
their semantics is significantly different from normal identifiers;
I occasionally fall for this when I'm tired), and the code reads
very nicely like BNF. Please trust me on the merits of this
notation and allow it at least in these source files.
* Somewhat nicer output by default. Isn't silent on passing tests,
shows information on failing tests directly instead of putting them
into a log file. I feel that it's closer to the typical 'make check'
output we're used to from other programs, so I don't feel lost.
(No log file is produced at all by default, since it wouldn't contain
more output than the stdout. If this disturbs some people's workflow, I
can add the feature back.)
And also:
* The author is committed to maintaining it well for Guile
specifically. :-)
The implementation is tested against (an extended version of) Kawa's
SRFI-64 meta-test-suite, though it's in R7RS format in my repository; I
can port that to Guile too eventually.
If you think that the fact that this is a huge refactoring still means
it might contain more bugs than the original, then I'd like to point out
that the original contained at least one nontrivial bug for a long time
which in my opinion was likely a result of the sloppy style of the code
and the tendency of the code-base to mentally tire out a programmer. I
hope I don't sound like a crazy code cleanliness pedant, but I do think
it's fairly important.
(If you have time, you might want to skim through the original code-base
a bit, and then this one, to see what I mean.)
Guile's test suite passes with this patch.
If you disagree with my mostly subjective points and don't want to
accept this patch, no hard feelings. Guilifying the R7RS library was
trivial.
Taylan
>From b27ef7b4148bcfa9c0bc31856dcf1278c226da09 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<address@hidden>
Date: Tue, 1 Sep 2015 22:57:09 +0200
Subject: [PATCH] Switch to modernized SRFI-64 implementation.
* module/srfi/srfi-64.scm: Add imports and other boilerplate for new
implementation.
* module/srfi/srfi-64/execution.body.scm: New file.
* module/srfi/srfi-64/source-info.body.scm: New file.
* module/srfi/srfi-64/test-runner-simple.body.scm: New file.
* module/srfi/srfi-64/test-runner.body.scm: New file.
* module/srfi/srfi-64/testing.scm: Deleted.
* module/Makefile.am (srfi-64.go, NOCOMP_SOURCES): Change accordingly.
---
module/Makefile.am | 11 +-
module/srfi/srfi-64.scm | 12 +-
module/srfi/srfi-64/execution.body.scm | 377 ++++++++
module/srfi/srfi-64/source-info.body.scm | 56 ++
module/srfi/srfi-64/test-runner-simple.body.scm | 141 +++
module/srfi/srfi-64/test-runner.body.scm | 156 ++++
module/srfi/srfi-64/testing.scm | 1040 -----------------------
7 files changed, 750 insertions(+), 1043 deletions(-)
create mode 100644 module/srfi/srfi-64/execution.body.scm
create mode 100644 module/srfi/srfi-64/source-info.body.scm
create mode 100644 module/srfi/srfi-64/test-runner-simple.body.scm
create mode 100644 module/srfi/srfi-64/test-runner.body.scm
delete mode 100644 module/srfi/srfi-64/testing.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 13e5000..d52cb4f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -258,7 +258,11 @@ ICE_9_SOURCES = \
ice-9/local-eval.scm \
ice-9/unicode.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+srfi/srfi-64.go: srfi/srfi-64.scm \
+ srfi/srfi-64/execution.body.scm \
+ srfi/srfi-64/source-info.body.scm \
+ srfi/srfi-64/test-runner-simple.body.scm \
+ srfi/srfi-64/test-runner.body.scm
SRFI_SOURCES = \
srfi/srfi-2.scm \
@@ -401,7 +405,10 @@ NOCOMP_SOURCES = \
ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \
srfi/srfi-42/ec.scm \
- srfi/srfi-64/testing.scm \
+ srfi/srfi-64/execution.body.scm \
+ srfi/srfi-64/source-info.body.scm \
+ srfi/srfi-64/test-runner-simple.body.scm \
+ srfi/srfi-64/test-runner.body.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 81dcc5d..1dc14e0 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -52,4 +52,14 @@
(cond-expand-provide (current-module) '(srfi-64))
-(include-from-path "srfi/srfi-64/testing.scm")
+(import
+ (only (rnrs exceptions) guard)
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-11)
+ (srfi srfi-35))
+
+(include-from-path "srfi/srfi-64/source-info.body.scm")
+(include-from-path "srfi/srfi-64/test-runner.body.scm")
+(include-from-path "srfi/srfi-64/test-runner-simple.body.scm")
+(include-from-path "srfi/srfi-64/execution.body.scm")
diff --git a/module/srfi/srfi-64/execution.body.scm
b/module/srfi/srfi-64/execution.body.scm
new file mode 100644
index 0000000..5959646
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,377 @@
+;; 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 <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+
+;;; Grouping
+
+(define-syntax test-begin
+ (syntax-rules ()
+ ((_ <name>)
+ (test-begin <name> #f))
+ ((_ <name> count)
+ (let ((name <name>))
+ (when (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((r (test-runner-current)))
+ (let ((skip-list (%test-runner-skip-list r))
+ (skip-save (%test-runner-skip-save r))
+ (fail-list (%test-runner-fail-list r))
+ (fail-save (%test-runner-fail-save r))
+ (total-count (%test-runner-total-count r))
+ (count-list (%test-runner-count-list r))
+ (group-stack (test-runner-group-stack r)))
+ ((test-runner-on-group-begin r) r name count)
+ (%test-runner-skip-save! r (cons skip-list skip-save))
+ (%test-runner-fail-save! r (cons fail-list fail-save))
+ (%test-runner-count-list! r (cons (cons total-count count)
+ count-list))
+ (test-runner-group-stack! r (cons name group-stack))))))))
+
+(define-syntax test-end
+ (syntax-rules ()
+ ((_)
+ (test-end #f))
+ ((_ <name>)
+ (let ((name <name>))
+ (let* ((r (test-runner-get))
+ (groups (test-runner-group-stack r)))
+ (test-result-clear r)
+ (when (null? groups)
+ (error "test-end not in a group"))
+ (when (and name (not (equal? name (car groups))))
+ ((test-runner-on-bad-end-name r) r 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)))
+ (when (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))
+ (when (null? (test-runner-group-stack r))
+ ((test-runner-on-final r) r))))))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ <name> <body> <body>* ...)
+ (begin
+ (when (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((runner (test-runner-get))
+ (name <name>))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ (lambda () <body> <body>* ...)
+ (lambda () (test-end name)))))))))
+
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ ((_ <name> <body> <body>* ... <cleanup>)
+ (test-group <name>
+ (dynamic-wind (lambda () #f)
+ (lambda () <body> <body>* ...)
+ (lambda () <cleanup>))))))
+
+
+;;; Skipping, expected-failing, matching
+
+(define (test-skip . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-skip-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-skip-list runner)))))
+
+(define (test-skip? runner)
+ (let ((run-list (%test-runner-run-list runner))
+ (skip-list (%test-runner-skip-list runner)))
+ (or (and run-list (not (any-pred run-list runner)))
+ (any-pred skip-list runner))))
+
+(define (test-expect-fail . specs)
+ (let ((runner (test-runner-get)))
+ (%test-runner-fail-list!
+ runner (cons (apply test-match-all specs)
+ (%test-runner-fail-list runner)))))
+
+(define (test-match-any . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (any-pred preds runner))))
+
+(define (test-match-all . specs)
+ (let ((preds (map make-pred specs)))
+ (lambda (runner)
+ (every-pred preds runner))))
+
+(define (make-pred spec)
+ (cond
+ ((procedure? spec)
+ spec)
+ ((integer? spec)
+ (test-match-nth 1 spec))
+ ((string? spec)
+ (test-match-name spec))
+ (else
+ (error "not a valid test specifier" spec))))
+
+(define test-match-nth
+ (case-lambda
+ ((n) (test-match-nth n 1))
+ ((n count)
+ (let ((i 0))
+ (lambda (runner)
+ (set! i (+ i 1))
+ (and (>= i n) (< i (+ n count))))))))
+
+(define (test-match-name name)
+ (lambda (runner)
+ (equal? name (test-runner-test-name runner))))
+
+;;; Beware: all predicates must be called because they might have side-effects;
+;;; no early returning or and/or short-circuiting of procedure calls allowed.
+
+(define (any-pred preds object)
+ (let loop ((matched? #f)
+ (preds preds))
+ (if (null? preds)
+ matched?
+ (let ((result ((car preds) object)))
+ (loop (or matched? result)
+ (cdr preds))))))
+
+(define (every-pred preds object)
+ (let loop ((failed? #f)
+ (preds preds))
+ (if (null? preds)
+ (not failed?)
+ (let ((result ((car preds) object)))
+ (loop (or failed? (not result))
+ (cdr preds))))))
+
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+;;; This must be syntax for set-source-info! to work right.
+(define-syntax test-prelude
+ (syntax-rules ()
+ ((_ <runner> <name> <expression>)
+ (let ((runner <runner>)
+ (name <name>)
+ (expression <expression>))
+ (test-result-clear runner)
+ (set-source-info! runner)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form expression)
+ (let ((skip? (test-skip? runner)))
+ (if skip?
+ (test-result-set! runner 'result-kind 'skip)
+ (let ((fail-list (%test-runner-fail-list runner)))
+ (when (any-pred fail-list runner)
+ ;; For later inspection only.
+ (test-result-set! runner 'result-kind 'xfail))))
+ ((test-runner-on-test-begin runner) runner)
+ (not skip?))))))
+
+(define (test-postlude runner)
+ (let ((result-kind (test-result-kind runner)))
+ (case result-kind
+ ((pass)
+ (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner))))
+ ((fail)
+ (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner))))
+ ((xpass)
+ (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count
runner))))
+ ((xfail)
+ (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count
runner))))
+ ((skip)
+ (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner)))))
+ (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner)))
+ ((test-runner-on-test-end runner) runner)))
+
+(define (set-result-kind! runner pass?)
+ (test-result-set! runner 'result-kind
+ (if (eq? (test-result-kind runner) 'xfail)
+ (if pass? 'xpass 'xfail)
+ (if pass? 'pass 'fail))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ <expr>)
+ (test-assert #f <expr>))
+ ((_ <name> <expr>)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude runner <name> '<expr>)
+ (let ((val (false-if-error <expr> runner)))
+ (test-result-set! runner 'actual-value val)
+ (set-result-kind! runner val)))
+ (test-postlude runner)))))
+
+(define-syntax test-compare
+ (syntax-rules ()
+ ((_ <compare> <expected> <expr>)
+ (test-compare <compare> #f <expected> <expr>))
+ ((_ <compare> <name> <expected> <expr>)
+ (let ((runner (test-runner-get))
+ (name <name>))
+ (when (test-prelude runner name '<expr>)
+ (let ((expected <expected>))
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val <expr>))
+ (test-result-set! runner 'actual-value val)
+ (<compare> expected val))
+ runner)))
+ (set-result-kind! runner pass?))))
+ (test-postlude runner)))))
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare equal? . <rest>))))
+
+(define-syntax test-eqv
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare eqv? . <rest>))))
+
+(define-syntax test-eq
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare eq? . <rest>))))
+
+(define (approx= margin)
+ (lambda (value expected)
+ (let ((rval (real-part value))
+ (ival (imag-part value))
+ (rexp (real-part expected))
+ (iexp (imag-part expected)))
+ (and (>= rval (- rexp margin))
+ (>= ival (- iexp margin))
+ (<= rval (+ rexp margin))
+ (<= ival (+ iexp margin))))))
+
+(define-syntax test-approximate
+ (syntax-rules ()
+ ((_ <expected> <expr> <margin>)
+ (test-approximate #f <expected> <expr> <error>))
+ ((_ <name> <expected> <expr> <error>)
+ (test-compare (approx= <margin>) <name> <expected> <expr>))))
+
+(define (error-matches? error type)
+ (cond
+ ((eq? type #t)
+ #t)
+ ((condition-type? type)
+ (and (condition? error) (condition-has-type? error type)))
+ ((procedure? type)
+ (type error))
+ (else
+ (format #t "WARNING: unknown error type predicate: ~a~%" type)
+ (format #t " error was: ~a~%" error)
+ #f)))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ <expr>)
+ (test-error #f #t <expr>))
+ ((_ <error-type> <expr>)
+ (test-error #f <error-type> <expr>))
+ ((_ <name> <error-type> <expr>)
+ (let ((runner (test-runner-get))
+ (name <name>))
+ (when (test-prelude runner name '<expr>)
+ (let ((error-type <error-type>))
+ (test-result-set! runner 'expected-error error-type)
+ (let ((pass? (guard (error (else (test-result-set!
+ runner 'actual-error error)
+ (error-matches? error error-type)))
+ (let ((val <expr>))
+ (test-result-set! runner 'actual-value val))
+ #f)))
+ (set-result-kind! runner pass?))))
+ (test-postlude runner)))))
+
+(define test-read-eval-string
+ (case-lambda
+ ((string)
+ (test-read-eval-string string (cond-expand
+ (guile (current-module))
+ (else #f))))
+ ((string env)
+ (let* ((port (open-input-string string))
+ (form (read port)))
+ (if (eof-object? (read-char port))
+ (if env
+ (eval form env)
+ (eval form))
+ (error "(not at eof)"))))))
+
+
+;;; Test runner control flow
+
+(define-syntax test-with-runner
+ (syntax-rules ()
+ ((_ <runner> <body> <body>* ...)
+ (let ((saved-runner (test-runner-current)))
+ (dynamic-wind
+ (lambda () (test-runner-current <runner>))
+ (lambda () <body> <body>* ...)
+ (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+ (let ((runner (if (test-runner? first)
+ first
+ (or (test-runner-current) (test-runner-create))))
+ (run-list (if (test-runner? first)
+ (drop-right rest 1)
+ (cons first (drop-right rest 1))))
+ (proc (last rest)))
+ (test-with-runner runner
+ (let ((saved-run-list (%test-runner-run-list runner)))
+ (%test-runner-run-list! runner run-list)
+ (proc)
+ (%test-runner-run-list! runner saved-run-list)))))
+
+;;; execution.scm ends here
diff --git a/module/srfi/srfi-64/source-info.body.scm
b/module/srfi/srfi-64/source-info.body.scm
new file mode 100644
index 0000000..52bf5f7
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,56 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <address@hidden>
+;;
+;; 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.
+
+(define-syntax set-source-info!
+ (cond-expand
+ ((or kawa guile-2)
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <runner>)
+ (let ((file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (begin
+ (test-result-set! <runner> 'source-file (unsyntax file))
+ (test-result-set! <runner> 'source-line (unsyntax line)))))))))
+ (else
+ (syntax-rules ()
+ ((_ <runner>)
+ (values))))))
+
+(define (syntax-source-file stx)
+ (cond-expand
+ (kawa
+ (syntax-source stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'filename))))))
+
+(define (syntax-source-line stx)
+ (cond-expand
+ (kawa
+ (syntax-line stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'line))))))
+
+;;; source-info.body.scm ends here
diff --git a/module/srfi/srfi-64/test-runner-simple.body.scm
b/module/srfi/srfi-64/test-runner-simple.body.scm
new file mode 100644
index 0000000..f55bf5c
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,141 @@
+;; 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 <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+;;; Helpers
+
+(define (string-join strings delimiter)
+ (if (null? strings)
+ ""
+ (let loop ((result (car strings))
+ (rest (cdr strings)))
+ (if (null? rest)
+ result
+ (loop (string-append result delimiter (car rest))
+ (cdr rest))))))
+
+(define (truncate-string string length)
+ (let* ((fill "...")
+ (fill-len (string-length fill))
+ (string-len (string-length string)))
+ (if (<= string-len (+ length 3))
+ string
+ (let-values (((q r) (floor/ length 4)))
+ ;; Left part gets 3/4 plus the remainder.
+ (let ((left-end (+ (* q 3) r))
+ (right-start (- string-len q)))
+ (string-append (substring string 0 left-end)
+ fill
+ (substring string right-start string-len)))))))
+
+;;; Main
+
+(define (test-runner-simple)
+ (let ((runner (test-runner-null)))
+ (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))
+
+(when (not (test-runner-factory))
+ (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+ (if (null? (test-runner-group-stack runner))
+ (format #t "Test suite begin: ~a~%" name)
+ (format #t "Group begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+ (let ((name (car (test-runner-group-stack runner))))
+ (if (= 1 (length (test-runner-group-stack runner)))
+ (format #t "Test suite end: ~a~%" name)
+ (format #t "Group end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (format #t "Passes: ~a\n" (test-runner-pass-count runner))
+ (format #t "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (format #t "Failures: ~a\n" (test-runner-fail-count runner))
+ (format #t "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (format #t "Skipped tests: ~a~%" (test-runner-skip-count runner)))
+
+(define (test-on-test-begin-simple runner)
+ (values))
+
+(define (test-on-test-end-simple runner)
+ (let* ((result-kind (test-result-kind runner))
+ (result-kind-name (case result-kind
+ ((pass) "PASS") ((fail) "FAIL")
+ ((xpass) "XPASS") ((xfail) "XFAIL")
+ ((skip) "SKIP")))
+ (name (let ((name (test-runner-test-name runner)))
+ (if (string=? "" name)
+ (truncate-string
+ (format #f "~a" (test-result-ref runner 'source-form))
+ 30)
+ name)))
+ (label (string-join (append (test-runner-group-path runner)
+ (list name))
+ "/")))
+ (format #t "[~a] ~a~%" result-kind-name label)
+ (when (memq result-kind '(fail xpass))
+ (let ((nil (cons #f #f)))
+ (define (found? value)
+ (not (eq? nil value)))
+ (define (maybe-print value message)
+ (when (found? value)
+ (format #t message value)))
+ (let ((file (test-result-ref runner 'source-file))
+ (line (test-result-ref runner 'source-line))
+ (expression (test-result-ref runner 'source-form))
+ (expected-value (test-result-ref runner 'expected-value nil))
+ (actual-value (test-result-ref runner 'actual-value nil))
+ (expected-error (test-result-ref runner 'expected-error nil))
+ (actual-error (test-result-ref runner 'actual-error nil)))
+ (newline)
+ (when line
+ (format #t "Source:\n~a:~a\n~%" (or file "(unknown file)") line))
+ (format #t "Expression:\n~a\n~%" expression)
+ (maybe-print expected-value "Expected value:\n~a\n~%")
+ (maybe-print expected-error "Expected error:\n~a\n~%")
+ (when (or (found? expected-value) (found? expected-error))
+ (maybe-print actual-value "Got value:\n~a\n~%"))
+ (maybe-print actual-error "Got error:\n~a\n~%"))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (format #t "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (format #t "*** Discrepancy indicates testsuite error or exceptions. ***~%"))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"."
+ end-name begin-name)))
+
+;;; test-runner-simple.scm ends here
diff --git a/module/srfi/srfi-64/test-runner.body.scm
b/module/srfi/srfi-64/test-runner.body.scm
new file mode 100644
index 0000000..be0c5a3
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,156 @@
+;; 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 <address@hidden>, Copyright (c) 2014.
+;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015.
+;;
+;; 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.
+
+
+;;; The data type
+
+(define-record-type <test-runner>
+ (make-test-runner) test-runner?
+
+ (result-alist test-result-alist test-result-alist!)
+
+ (pass-count test-runner-pass-count test-runner-pass-count!)
+ (fail-count test-runner-fail-count test-runner-fail-count!)
+ (xpass-count test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count test-runner-skip-count test-runner-skip-count!)
+ (total-count %test-runner-total-count %test-runner-total-count!)
+
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list %test-runner-count-list %test-runner-count-list!)
+
+ ;; Normally #f, except when in a test-apply.
+ (run-list %test-runner-run-list %test-runner-run-list!)
+
+ (skip-list %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list %test-runner-fail-list %test-runner-fail-list!)
+
+ (skip-save %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save %test-runner-fail-save %test-runner-fail-save!)
+
+ (group-stack test-runner-group-stack test-runner-group-stack!)
+
+ ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and
+ ;; test-end forms in the execution library. They're called at the
+ ;; beginning/end of each individual test, whereas the test-begin and test-end
+ ;; forms demarcate test groups.
+
+ (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!)
+ (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!)
+ (on-group-end test-runner-on-group-end test-runner-on-group-end!)
+ (on-final test-runner-on-final test-runner-on-final!)
+ (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!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!))
+
+(define (test-runner-group-path runner)
+ (reverse (test-runner-group-stack runner)))
+
+(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 #f)
+ (%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-null)
+ (define (test-null-callback . args) #f)
+ (let ((runner (make-test-runner)))
+ (test-runner-reset runner)
+ (test-runner-on-group-begin! runner test-null-callback)
+ (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 test-null-callback)
+ (test-runner-on-bad-end-name! runner test-null-callback)
+ runner))
+
+
+;;; State
+
+(define test-result-ref
+ (case-lambda
+ ((runner key)
+ (test-result-ref runner key #f))
+ ((runner key default)
+ (let ((entry (assq key (test-result-alist runner))))
+ (if entry (cdr entry) default)))))
+
+(define (test-result-set! runner key value)
+ (let* ((alist (test-result-alist runner))
+ (entry (assq key alist)))
+ (if entry
+ (set-cdr! entry value)
+ (test-result-alist! runner (cons (cons key value) alist)))))
+
+(define (test-result-remove runner key)
+ (test-result-alist! runner (remove (lambda (entry)
+ (eq? key (car entry)))
+ (test-result-alist runner))))
+
+(define (test-result-clear runner)
+ (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+ (or (test-result-ref runner 'name) ""))
+
+(define test-result-kind
+ (case-lambda
+ (() (test-result-kind (test-runner-get)))
+ ((runner) (test-result-ref runner 'result-kind))))
+
+(define test-passed?
+ (case-lambda
+ (() (test-passed? (test-runner-get)))
+ ((runner) (memq (test-result-kind runner) '(pass xpass)))))
+
+
+;;; Factory and current instance
+
+(define test-runner-factory (make-parameter #f))
+
+(define (test-runner-create) ((test-runner-factory)))
+
+(define test-runner-current (make-parameter #f))
+
+(define (test-runner-get)
+ (or (test-runner-current)
+ (error "test-runner not initialized - test-begin missing?")))
+
+;;; test-runner.scm ends here
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
deleted file mode 100644
index d686662..0000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1040 +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 <address@hidden>, 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))
- (test-runner-current (test-runner-create)))
- (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")))))
-
--
2.5.0
- [PATCH] Switch to modernized SRFI-64 implementation.,
Taylan Ulrich Bayırlı/Kammer <=