* [PATCH] Switch to modernized SRFI-64 implementation.
@ 2015-09-02 10:55 Taylan Ulrich Bayırlı/Kammer
2015-09-22 9:27 ` Taylan Ulrich Bayırlı/Kammer
0 siblings, 1 reply; 5+ messages in thread
From: Taylan Ulrich Bayırlı/Kammer @ 2015-09-02 10:55 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 3462 bytes --]
(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
[-- Attachment #2: 0001-Switch-to-modernized-SRFI-64-implementation.patch --]
[-- Type: text/x-diff, Size: 71992 bytes --]
From b27ef7b4148bcfa9c0bc31856dcf1278c226da09 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayirli@gmail.com>
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 <mhw@netris.org>, 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.
+
+\f
+;;; 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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; 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)"))))))
+
+\f
+;;; 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 <taylanbayirli@gmail.com>
+;;
+;; 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 <mhw@netris.org>, 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 <mhw@netris.org>, 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.
+
+\f
+;;; 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))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 <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))
- (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Switch to modernized SRFI-64 implementation.
2015-09-02 10:55 [PATCH] Switch to modernized SRFI-64 implementation Taylan Ulrich Bayırlı/Kammer
@ 2015-09-22 9:27 ` Taylan Ulrich Bayırlı/Kammer
2015-09-22 14:00 ` Taylan Ulrich Bayırlı/Kammer
0 siblings, 1 reply; 5+ messages in thread
From: Taylan Ulrich Bayırlı/Kammer @ 2015-09-22 9:27 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 348 bytes --]
taylanbayirli@gmail.com (Taylan Ulrich "Bayırlı/Kammer") writes:
> This patch swaps out our SRFI-64 implementation for the one hosted at:
>
> https://github.com/taylanub/scheme-srfis
There has since been one bug fix, and a refactoring of the macros for
better compile times, so here's an updated patch that uses the updated
version.
[-- Attachment #2: 0001-Switch-to-modernized-SRFI-64-implementation.patch --]
[-- Type: text/x-diff, Size: 71875 bytes --]
From 05254ab75f9663062ecfb0bba94d6e653a09b703 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayirli@gmail.com>
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 | 378 ++++++++
module/srfi/srfi-64/source-info.body.scm | 59 ++
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, 754 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..e1f90f7
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,378 @@
+;; 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.
+;; 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.
+
+\f
+;;; Grouping
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (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 test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((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>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (when (not (test-runner-current))
+ (test-runner-current (test-runner-create)))
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (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>)
+ (%test-assert (source-info) <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) 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>)
+ (%test-compare
+ (source-info) <compare> <name> <expected> '<expr> (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (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> <error-margin>)
+ (test-approximate #f <expected> <expr> <error-margin>))
+ ((_ <name> <expected> <expr> <error-margin>)
+ (test-compare (approx= <error-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>)
+ (%test-error
+ (source-info) <name> <error-type> '<expr> (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (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 (thunk)))
+ (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)"))))))
+
+\f
+;;; 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..c1c6f97
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,59 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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 source-info
+ (cond-expand
+ ((or kawa guile-2)
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_)
+ (let ((file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line))))))))
+ (else
+ (syntax-rules ()
+ ((_)
+ #f)))))
+
+(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))))))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; 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 <mhw@netris.org>, 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 <mhw@netris.org>, 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.
+
+\f
+;;; 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))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 <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))
- (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Switch to modernized SRFI-64 implementation.
2015-09-22 9:27 ` Taylan Ulrich Bayırlı/Kammer
@ 2015-09-22 14:00 ` Taylan Ulrich Bayırlı/Kammer
2015-09-22 22:26 ` Taylan Ulrich Bayırlı/Kammer
0 siblings, 1 reply; 5+ messages in thread
From: Taylan Ulrich Bayırlı/Kammer @ 2015-09-22 14:00 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1336 bytes --]
taylanbayirli@gmail.com (Taylan Ulrich "Bayırlı/Kammer") writes:
> taylanbayirli@gmail.com (Taylan Ulrich "Bayırlı/Kammer") writes:
>
>> This patch swaps out our SRFI-64 implementation for the one hosted at:
>>
>> https://github.com/taylanub/scheme-srfis
>
> There has since been one bug fix, and a refactoring of the macros for
> better compile times, so here's an updated patch that uses the updated
> version.
While I was on it, I decided to add logging support.
Note that the implementation follows the spec closely, so a test runner
returned by (test-runner-simple) doesn't do logging by default (and
doesn't use its "aux value" field), contrary to the upstream
implementation which doesn't follow the specification so closely.
Logging is enabled on a simple test runner by setting a log file name
via 'test-runner-log-file!' (a non-standard extension). This is done
automatically when using 'test-begin' (or 'test-group') without first
installing a test runner explicitly, thus the behavior is the same as
upstream SRFI-64 in the most usual case, without needing the user to use
the non-standard extension.
This was the only thing upstream SRFI-64 was capable of which this
implementation wasn't, so I believe this implementation is now very
strictly an improvement over the upstream one.
[-- Attachment #2: 0001-Switch-to-modernized-SRFI-64-implementation.patch --]
[-- Type: text/x-diff, Size: 73254 bytes --]
From b49f0a2429f32e64d4e8507416bbb6b2f2b202a9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayirli@gmail.com>
Date: Tue, 1 Sep 2015 22:57:09 +0200
Subject: [PATCH 1/2] 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 | 387 +++++++++
module/srfi/srfi-64/source-info.body.scm | 59 ++
module/srfi/srfi-64/test-runner-simple.body.scm | 163 ++++
module/srfi/srfi-64/test-runner.body.scm | 159 ++++
module/srfi/srfi-64/testing.scm | 1040 -----------------------
7 files changed, 788 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 7e96de7..178c6f1 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 \
@@ -400,7 +404,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..b099dd2
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,387 @@
+;; 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.
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+\f
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+ (when (not (test-runner-current))
+ (let ((runner (test-runner-simple))
+ (log-file (string-append suite-name ".log")))
+ (test-runner-log-file! runner log-file)
+ (test-runner-current runner))))
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (maybe-install-default-runner name)
+ (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 test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((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>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (maybe-install-default-runner name)
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (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>)
+ (%test-assert (source-info) <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) 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>)
+ (%test-compare
+ (source-info) <compare> <name> <expected> '<expr> (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (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> <error-margin>)
+ (test-approximate #f <expected> <expr> <error-margin>))
+ ((_ <name> <expected> <expr> <error-margin>)
+ (test-compare (approx= <error-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>)
+ (%test-error
+ (source-info) <name> <error-type> '<expr> (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (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 (thunk)))
+ (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)"))))))
+
+\f
+;;; 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..c1c6f97
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,59 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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 source-info
+ (cond-expand
+ ((or kawa guile-2)
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_)
+ (let ((file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line))))))))
+ (else
+ (syntax-rules ()
+ ((_)
+ #f)))))
+
+(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))))))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; 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..bd00666
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,163 @@
+;; 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.
+;; 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 fill-len))
+ 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)))))))
+
+(define (print runner format-string . args)
+ (apply format #t format-string args)
+ (let ((port (test-runner-log-port runner)))
+ (when port
+ (apply format port format-string args))))
+
+;;; 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))
+ (begin
+ (maybe-start-logging runner)
+ (print runner "Test suite begin: ~a~%" name))
+ (print runner "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)))
+ (print runner "Test suite end: ~a~%" name)
+ (print runner "Group end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (print runner "Passes: ~a\n" (test-runner-pass-count runner))
+ (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (print runner "Failures: ~a\n" (test-runner-fail-count runner))
+ (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner))
+ (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+ (let ((log-file (test-runner-log-file runner)))
+ (when log-file
+ (test-runner-log-port! runner (open-output-file log-file))
+ (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+ (let ((log-file (test-runner-log-file runner)))
+ (when log-file
+ (print runner "Wrote log file: ~a~%" log-file)
+ (close-output-port (test-runner-log-port 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))
+ "/")))
+ (print runner "[~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)
+ (print runner 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
+ (print runner "Source:\n~a:~a\n~%" (or file "(unknown file)") line))
+ (print runner "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)
+ (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (print runner
+ "*** 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..8bf4ba2
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,159 @@
+;; 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.
+;; 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.
+
+\f
+;;; 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!)
+
+ (log-file test-runner-log-file test-runner-log-file!)
+ (log-port test-runner-log-port test-runner-log-port!))
+
+(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))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 <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))
- (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Switch to modernized SRFI-64 implementation.
2015-09-22 14:00 ` Taylan Ulrich Bayırlı/Kammer
@ 2015-09-22 22:26 ` Taylan Ulrich Bayırlı/Kammer
2015-10-02 10:27 ` Taylan Ulrich Bayırlı/Kammer
0 siblings, 1 reply; 5+ messages in thread
From: Taylan Ulrich Bayırlı/Kammer @ 2015-09-22 22:26 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 397 bytes --]
And here's another small update. (As usual, I'm sending a new patch in
whole. Tell me if you prefer otherwise. The individual changes can
also be seen in my repo of course.)
This adds a 'test-exit' procedure as suggested to me by John Cowan. It
exits with a non-zero exit status if any tests failed (or unexpectedly
passed), and a zero exit status otherwise.
Sorry about the rapid updates.
[-- Attachment #2: 0001-Switch-to-modernized-SRFI-64-implementation.patch --]
[-- Type: text/x-diff, Size: 74270 bytes --]
From aaa06d07843bb916471067a2835664ab897bab58 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayirli@gmail.com>
Date: Tue, 1 Sep 2015 22:57:09 +0200
Subject: [PATCH 1/2] 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 | 14 +-
module/srfi/srfi-64/execution.body.scm | 397 +++++++++
module/srfi/srfi-64/source-info.body.scm | 60 ++
module/srfi/srfi-64/test-runner-simple.body.scm | 163 ++++
module/srfi/srfi-64/test-runner.body.scm | 161 ++++
module/srfi/srfi-64/testing.scm | 1040 -----------------------
7 files changed, 802 insertions(+), 1044 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 7e96de7..178c6f1 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 \
@@ -400,7 +404,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..e6c6ce8 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -24,9 +24,9 @@
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-exit
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
@@ -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..ff55b76
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,397 @@
+;; 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.
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+\f
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+ (when (not (test-runner-current))
+ (let ((runner (test-runner-simple))
+ (log-file (string-append suite-name ".log")))
+ (test-runner-log-file! runner log-file)
+ (test-runner-current runner))))
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (maybe-install-default-runner name)
+ (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 test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((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>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (maybe-install-default-runner name)
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (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>)
+ (%test-assert (source-info <expr>) <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) 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>)
+ (%test-compare (source-info <expr>) <compare> <name> <expected> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (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> <error-margin>)
+ (test-approximate #f <expected> <expr> <error-margin>))
+ ((_ <name> <expected> <expr> <error-margin>)
+ (test-compare (approx= <error-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>)
+ (%test-error (source-info <expr>) <name> <error-type> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (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 (thunk)))
+ (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)"))))))
+
+\f
+;;; 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)))))
+
+\f
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+ (let ((runner (test-runner-current)))
+ (if (and (zero? (test-runner-xpass-count runner))
+ (zero? (test-runner-fail-count runner)))
+ (exit 0)
+ (exit 1))))
+
+;;; 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..505ab13
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,60 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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 source-info
+ (cond-expand
+ ((or kawa guile-2)
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <x>)
+ (let* ((stx (cond-expand (kawa (syntax <x>)) (guile stx) (else)))
+ (file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line))))))))
+ (else
+ (syntax-rules ()
+ ((_ <x>)
+ #f)))))
+
+(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))))))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; 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..bd00666
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,163 @@
+;; 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.
+;; 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 fill-len))
+ 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)))))))
+
+(define (print runner format-string . args)
+ (apply format #t format-string args)
+ (let ((port (test-runner-log-port runner)))
+ (when port
+ (apply format port format-string args))))
+
+;;; 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))
+ (begin
+ (maybe-start-logging runner)
+ (print runner "Test suite begin: ~a~%" name))
+ (print runner "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)))
+ (print runner "Test suite end: ~a~%" name)
+ (print runner "Group end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (print runner "Passes: ~a\n" (test-runner-pass-count runner))
+ (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (print runner "Failures: ~a\n" (test-runner-fail-count runner))
+ (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner))
+ (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+ (let ((log-file (test-runner-log-file runner)))
+ (when log-file
+ (test-runner-log-port! runner (open-output-file log-file))
+ (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+ (let ((log-file (test-runner-log-file runner)))
+ (when log-file
+ (print runner "Wrote log file: ~a~%" log-file)
+ (close-output-port (test-runner-log-port 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))
+ "/")))
+ (print runner "[~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)
+ (print runner 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
+ (print runner "Source:\n~a:~a\n~%" (or file "(unknown file)") line))
+ (print runner "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)
+ (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (print runner
+ "*** 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..f90ef16
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,161 @@
+;; 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.
+;; 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.
+
+\f
+;;; 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!)
+
+ (log-file test-runner-log-file test-runner-log-file!)
+ (log-port test-runner-log-port test-runner-log-port!))
+
+(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)
+ (test-runner-log-file! runner #f)
+ (test-runner-log-port! runner #f)
+ runner))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 <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))
- (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
* Re: [PATCH] Switch to modernized SRFI-64 implementation.
2015-09-22 22:26 ` Taylan Ulrich Bayırlı/Kammer
@ 2015-10-02 10:27 ` Taylan Ulrich Bayırlı/Kammer
0 siblings, 0 replies; 5+ messages in thread
From: Taylan Ulrich Bayırlı/Kammer @ 2015-10-02 10:27 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 382 bytes --]
Here's another update. (As always, tell me if you need it as a patch
against another version I sent to the ML.)
Summary:
The log file name is now *.srfi64.log to make surer that no file gets
accidentally overwritten.
The output format is also made more readable.
Other changes are mostly minor cleanup of architecture, and fixes for
Kawa and Larceny that don't concern Guile.
[-- Attachment #2: 0001-Switch-to-modernized-SRFI-64-implementation.patch --]
[-- Type: text/x-diff, Size: 77318 bytes --]
From c880143ecfbf715ec320ef623e91a421d8a53503 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayirli@gmail.com>
Date: Tue, 1 Sep 2015 22:57:09 +0200
Subject: [PATCH 1/2] 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 | 14 +-
module/srfi/srfi-64/execution.body.scm | 426 ++++++++++
module/srfi/srfi-64/source-info.body.scm | 88 ++
module/srfi/srfi-64/test-runner-simple.body.scm | 168 ++++
module/srfi/srfi-64/test-runner.body.scm | 165 ++++
module/srfi/srfi-64/testing.scm | 1040 -----------------------
7 files changed, 868 insertions(+), 1044 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 7e96de7..178c6f1 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 \
@@ -400,7 +404,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..e6c6ce8 100644
--- a/module/srfi/srfi-64.scm
+++ b/module/srfi/srfi-64.scm
@@ -24,9 +24,9 @@
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-exit
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
@@ -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..717d74b
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,426 @@
+;; 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.
+;; 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.
+
+;;; Note: to prevent producing massive amounts of code from the macro-expand
+;;; phase (which makes compile times suffer and may hit code size limits in some
+;;; systems), keep macro bodies minimal by delegating work to procedures.
+
+\f
+;;; Grouping
+
+(define (maybe-install-default-runner suite-name)
+ (when (not (test-runner-current))
+ (let ((runner (test-runner-simple))
+ (log-file (string-append suite-name ".srfi64.log")))
+ (%test-runner-log-file! runner log-file)
+ (test-runner-current runner))))
+
+(define test-begin
+ (case-lambda
+ ((name)
+ (test-begin name #f))
+ ((name count)
+ (maybe-install-default-runner name)
+ (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 test-end
+ (case-lambda
+ (()
+ (test-end #f))
+ ((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>*)
+ (%test-group <name> (lambda () <body> . <body>*)))))
+
+(define (%test-group name thunk)
+ (begin
+ (maybe-install-default-runner name)
+ (let ((runner (test-runner-get)))
+ (test-result-clear runner)
+ (test-result-set! runner 'name name)
+ (unless (test-skip? runner)
+ (dynamic-wind
+ (lambda () (test-begin name))
+ thunk
+ (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>))))))
+
+\f
+;;; 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))))))
+\f
+;;; Actual testing
+
+(define-syntax false-if-error
+ (syntax-rules ()
+ ((_ <expression> <runner>)
+ (guard (error
+ (else
+ (test-result-set! <runner> 'actual-error error)
+ #f))
+ <expression>))))
+
+(define (test-prelude source-info runner name form)
+ (test-result-clear runner)
+ (set-source-info! runner source-info)
+ (when name
+ (test-result-set! runner 'name name))
+ (test-result-set! runner 'source-form form)
+ (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))))
+
+;;; We need to use some trickery to get the source info right. The important
+;;; thing is to pass a syntax object that is a pair to `source-info', and make
+;;; sure this syntax object comes from user code and not from ourselves.
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-assert/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-assert/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-assert/source-info <source-info> #f <expr>))
+ ((_ <source-info> <name> <expr>)
+ (%test-assert <source-info> <name> '<expr> (lambda () <expr>)))))
+
+(define (%test-assert source-info name form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (let ((val (false-if-error (thunk) runner)))
+ (test-result-set! runner 'actual-value val)
+ (set-result-kind! runner val)))
+ (test-postlude runner)))
+
+(define-syntax test-compare
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-compare/source-info
+ (syntax-rules ()
+ ((_ <source-info> <compare> <expected> <expr>)
+ (test-compare/source-info <source-info> <compare> #f <expected> <expr>))
+ ((_ <source-info> <compare> <name> <expected> <expr>)
+ (%test-compare <source-info> <compare> <name> <expected> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-compare source-info compare name expected form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (test-result-set! runner 'expected-value expected)
+ (let ((pass? (false-if-error
+ (let ((val (thunk)))
+ (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/source-info (source-info <rest>) equal? . <rest>))))
+
+(define-syntax test-eqv
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) eqv? . <rest>))))
+
+(define-syntax test-eq
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-compare/source-info (source-info <rest>) 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 ()
+ ((_ . <rest>)
+ (test-approximate/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-approximate/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expected> <expr> <error-margin>)
+ (test-approximate/source-info
+ <source-info> #f <expected> <expr> <error-margin>))
+ ((_ <source-info> <name> <expected> <expr> <error-margin>)
+ (test-compare/source-info
+ <source-info> (approx= <error-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
+ (let ((runner (test-runner-get)))
+ ((%test-runner-on-bad-error-type runner) runner type error))
+ #f)))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ . <rest>)
+ (test-error/source-info (source-info <rest>) . <rest>))))
+
+(define-syntax test-error/source-info
+ (syntax-rules ()
+ ((_ <source-info> <expr>)
+ (test-error/source-info <source-info> #f #t <expr>))
+ ((_ <source-info> <error-type> <expr>)
+ (test-error/source-info <source-info> #f <error-type> <expr>))
+ ((_ <source-info> <name> <error-type> <expr>)
+ (%test-error <source-info> <name> <error-type> '<expr>
+ (lambda () <expr>)))))
+
+(define (%test-error source-info name error-type form thunk)
+ (let ((runner (test-runner-get)))
+ (when (test-prelude source-info runner name form)
+ (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 (thunk)))
+ (test-result-set! runner 'actual-value val))
+ #f)))
+ (set-result-kind! runner pass?)))
+ (test-postlude runner)))
+
+(define (default-module)
+ (cond-expand
+ (guile (current-module))
+ (else #f)))
+
+(define test-read-eval-string
+ (case-lambda
+ ((string)
+ (test-read-eval-string string (default-module)))
+ ((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)"))))))
+
+\f
+;;; 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)))))
+
+\f
+;;; Indicate success/failure via exit status
+
+(define (test-exit)
+ (let ((runner (test-runner-current)))
+ (if (and (zero? (test-runner-xpass-count runner))
+ (zero? (test-runner-fail-count runner)))
+ (exit 0)
+ (exit 1))))
+
+;;; 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..6848735
--- /dev/null
+++ b/module/srfi/srfi-64/source-info.body.scm
@@ -0,0 +1,88 @@
+;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;
+;; 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.
+
+;;; In some systems, a macro use like (source-info ...), that resides in a
+;;; syntax-rules macro body, first gets inserted into the place where the
+;;; syntax-rules macro was used, and then the transformer of 'source-info' is
+;;; called with a syntax object that has the source location information of that
+;;; position. That works fine when the user calls e.g. (test-assert ...), whose
+;;; body contains (source-info ...); the user gets the source location of the
+;;; (test-assert ...) call as intended, and not the source location of the real
+;;; (source-info ...) call.
+
+;;; In other systems, *first* the (source-info ...) is processed to get its real
+;;; position, which is within the body of a syntax-rules macro like test-assert,
+;;; so no matter where the user calls (test-assert ...), they get source
+;;; location information of where we defined test-assert with the call to
+;;; (source-info ...) in its body. That's arguably more correct behavior,
+;;; although in this case it makes our job a bit harder; we need to get the
+;;; source location from an argument to 'source-info' instead.
+
+(define (canonical-syntax form arg)
+ (cond-expand
+ (kawa arg)
+ (guile-2 form)
+ (else #f)))
+
+(cond-expand
+ ((or kawa guile-2)
+ (define-syntax source-info
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ <x>)
+ (let* ((stx (canonical-syntax stx (syntax <x>)))
+ (file (syntax-source-file stx))
+ (line (syntax-source-line stx)))
+ (quasisyntax
+ (cons (unsyntax file) (unsyntax line)))))))))
+ (else
+ (define-syntax source-info
+ (syntax-rules ()
+ ((_ <x>)
+ #f)))))
+
+(define (syntax-source-file stx)
+ (cond-expand
+ (kawa
+ (syntax-source stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'filename))))
+ (else
+ #f)))
+
+(define (syntax-source-line stx)
+ (cond-expand
+ (kawa
+ (syntax-line stx))
+ (guile-2
+ (let ((source (syntax-source stx)))
+ (and source (assq-ref source 'line))))
+ (else
+ #f)))
+
+(define (set-source-info! runner source-info)
+ (when source-info
+ (test-result-set! runner 'source-file (car source-info))
+ (test-result-set! runner 'source-line (cdr source-info))))
+
+;;; 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..f7ce2e3
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,168 @@
+;; 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.
+;; 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)
+ (define (newline->space c) (if (char=? #\newline c) #\space c))
+ (let* ((string (string-map newline->space string))
+ (fill "...")
+ (fill-len (string-length fill))
+ (string-len (string-length string)))
+ (if (<= string-len (+ length fill-len))
+ 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)))))))
+
+(define (print runner format-string . args)
+ (apply format #t format-string args)
+ (let ((port (%test-runner-log-port runner)))
+ (when port
+ (apply format port format-string args))))
+
+;;; 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)
+ (%test-runner-on-bad-error-type! runner on-bad-error-type)
+ runner))
+
+(when (not (test-runner-factory))
+ (test-runner-factory test-runner-simple))
+
+(define (test-on-group-begin-simple runner name count)
+ (when (null? (test-runner-group-stack runner))
+ (maybe-start-logging runner)
+ (print runner "Test suite begin: ~a~%" name)))
+
+(define (test-on-group-end-simple runner)
+ (let ((name (car (test-runner-group-stack runner))))
+ (when (= 1 (length (test-runner-group-stack runner)))
+ (print runner "Test suite end: ~a~%" name))))
+
+(define (test-on-final-simple runner)
+ (print runner "Passes: ~a\n" (test-runner-pass-count runner))
+ (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner))
+ (print runner "Failures: ~a\n" (test-runner-fail-count runner))
+ (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner))
+ (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner))
+ (maybe-finish-logging runner))
+
+(define (maybe-start-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ ;; The possible race-condition here doesn't bother us.
+ (when (file-exists? log-file)
+ (delete-file log-file))
+ (%test-runner-log-port! runner (open-output-file log-file))
+ (print runner "Writing log file: ~a~%" log-file))))
+
+(define (maybe-finish-logging runner)
+ (let ((log-file (%test-runner-log-file runner)))
+ (when log-file
+ (print runner "Wrote log file: ~a~%" log-file)
+ (close-output-port (%test-runner-log-port 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))
+ ": ")))
+ (print runner "[~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)
+ (print runner message value)))
+ (let ((file (test-result-ref runner 'source-file "(unknown file)"))
+ (line (test-result-ref runner 'source-line "(unknown 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)))
+ (print runner "~a:~a: ~s~%" file line expression)
+ (maybe-print expected-value "Expected value: ~s~%")
+ (maybe-print expected-error "Expected error: ~a~%")
+ (when (or (found? expected-value) (found? expected-error))
+ (maybe-print actual-value "Returned value: ~s~%"))
+ (maybe-print actual-error "Raised error: ~a~%")
+ (newline))))))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (print runner "*** Total number of tests was ~a but should be ~a. ***~%"
+ count expected-count)
+ (print runner
+ "*** 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)))
+
+(define (on-bad-error-type runner type error)
+ (print runner "WARNING: unknown error type predicate: ~a~%" type)
+ (print runner " error was: ~a~%" error))
+
+;;; 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..f8131eb
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.body.scm
@@ -0,0 +1,165 @@
+;; 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.
+;; 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.
+
+\f
+;;; 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!)
+
+ (on-bad-error-type %test-runner-on-bad-error-type
+ %test-runner-on-bad-error-type!)
+
+ (aux-value test-runner-aux-value test-runner-aux-value!)
+
+ (log-file %test-runner-log-file %test-runner-log-file!)
+ (log-port %test-runner-log-port %test-runner-log-port!))
+
+(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)
+ (%test-runner-on-bad-error-type! runner test-null-callback)
+ (%test-runner-log-file! runner #f)
+ (%test-runner-log-port! runner #f)
+ runner))
+
+\f
+;;; 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)))))
+
+\f
+;;; 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 <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))
- (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
^ permalink raw reply related [flat|nested] 5+ messages in thread
end of thread, other threads:[~2015-10-02 10:27 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2015-09-02 10:55 [PATCH] Switch to modernized SRFI-64 implementation Taylan Ulrich Bayırlı/Kammer
2015-09-22 9:27 ` Taylan Ulrich Bayırlı/Kammer
2015-09-22 14:00 ` Taylan Ulrich Bayırlı/Kammer
2015-09-22 22:26 ` Taylan Ulrich Bayırlı/Kammer
2015-10-02 10:27 ` Taylan Ulrich Bayırlı/Kammer
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).