unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* [PATCHES] Use a better SRFI-64 implementation.
@ 2021-05-10 18:25 Taylan Kammer
  2021-05-11 11:32 ` Taylan Kammer
                   ` (2 more replies)
  0 siblings, 3 replies; 6+ messages in thread
From: Taylan Kammer @ 2021-05-10 18:25 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 1717 bytes --]

Hi Guile devs,

I've noticed there have been a couple bug reports about SRFI-64
recently.  Guile uses the reference implementation of SRFI-64 which has
really terrible readability, doesn't conform to its own standard, and
was revealed to have a number of bugs over the years.

I've attached two patches, the first of which replaces the SRFI-64
implementation shipped with Guile to the one I wrote as part of the R7RS
Scheme SRFIs project,[0] and the second patch adds a few tests to the
SRFI-64 meta test suite.

This implementation of SRFI-64 offers the following improvements:

- Much better readability through a modular design, modernized Scheme
code, better identifier names, and otherwise prettified code

- Output about executed tests in a format familiar to GNU users

- Improved expand-time performance for large test suites

- Fully conforms to the SRFI-64 specification

- Offers a small number of extensions

See the notes about SRFI-64 in the README of the Scheme SRFIs project[0]
for the most important differences from the reference implementation,
like the way it conforms to the spec where the reference implementation
doesn't, and the extensions mentioned above.


I had already proposed such a patch a number of years ago, but it was
rejected on the grounds that the upstream implementation is probably
better tested.  I think the fact that there have been grave bugs in the
implementation that remained uncovered in ~15 years evidences that this
is not a valid reason.  I believe that the over-complicated way the code
is written masks bugs and discourages people from improving the code.


What do you think?  IMO this would be a clear improvement.


[0] https://github.com/TaylanUB/scheme-srfis

[-- Attachment #2: 0001-Use-a-different-SRFI-64-implementation.patch --]
[-- Type: text/plain, Size: 37903 bytes --]

From fa23f90fe3e516e57e6f1ddae5517d7170c62f44 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:23:17 +0200
Subject: [PATCH 1/2] Use a different 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 ++++
 .../srfi/srfi-64/test-runner-simple.body.scm  | 168 +++++++
 module/srfi/srfi-64/test-runner.body.scm      | 165 +++++++
 6 files changed, 868 insertions(+), 4 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

diff --git a/module/Makefile.am b/module/Makefile.am
index 41b77095b..e1c5267e7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
 ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+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
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
 
 # Keep this rule in sync with that in `am/guilec'.
@@ -403,7 +407,10 @@ NOCOMP_SOURCES =				\
   ice-9/r7rs-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 925726f5c..a8cb08874 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
@@ -53,4 +53,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 000000000..717d74bfa
--- /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 000000000..684873587
--- /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 000000000..f7ce2e383
--- /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 000000000..f8131ebcf
--- /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
-- 
2.30.2


[-- Attachment #3: 0002-Augment-SRFI-64-test-suite.patch --]
[-- Type: text/plain, Size: 1901 bytes --]

From 5f7b1e3790f3941a12326aec10f90ca55fe0e1c3 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:26:10 +0200
Subject: [PATCH 2/2] Augment SRFI-64 test-suite.

* test-suite/tests/srfi-64-test.scm ("1.3. test-approximate"): New
  section.
("2.1.4. FAIL with a test name and error type"):
("2.1.5. PASS with an error type but no name"):
("2.1.6. FAIL with an error type but no name"): New tests.
---
 test-suite/tests/srfi-64-test.scm | 37 +++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..b7f6d2934 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -167,6 +167,19 @@
 
 (test-end);1.2
 
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-approximate "a" (mean 3 5) 4   0.001)
+    (test-approximate "b" (mean 3 5) 4.5 0.001)
+    (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
 (test-end "1. Simple test-cases")
 
 ;;;
@@ -202,6 +215,30 @@
     ;; PASS
     (test-error "a" #t (vector-ref '#(1 2) 9)))))
 
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error #t (vector-ref '#(1 2) 0)))))
+
 (test-end "2.1. test-error")
 
 (test-end "2. Tests for catching errors")
-- 
2.30.2


^ permalink raw reply related	[flat|nested] 6+ messages in thread

* Re: [PATCHES] Use a better SRFI-64 implementation.
  2021-05-10 18:25 [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
@ 2021-05-11 11:32 ` Taylan Kammer
  2021-05-11 19:14   ` Taylan Kammer
  2021-05-11 14:32 ` Taylan Kammer
  2021-05-11 19:39 ` Taylan Kammer
  2 siblings, 1 reply; 6+ messages in thread
From: Taylan Kammer @ 2021-05-11 11:32 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 231 bytes --]

While rebasing an old commit on master, I accidentally reinstated the
old implementation's .scm file in the first commit that's supposed to
delete that file.  (module/srfi/srfi-64/testing.scm)

Here's a fixed patch-set.


- Taylan

[-- Attachment #2: 0001-Use-a-different-SRFI-64-implementation.patch --]
[-- Type: text/plain, Size: 75651 bytes --]

From be7f22e65878f5cb5aa7e94873e4b35ef4ae0032 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:23:17 +0200
Subject: [PATCH 1/2] Use a different 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 ++
 .../srfi/srfi-64/test-runner-simple.body.scm  |  168 +++
 module/srfi/srfi-64/test-runner.body.scm      |  165 +++
 module/srfi/srfi-64/testing.scm               | 1044 -----------------
 7 files changed, 868 insertions(+), 1048 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 41b77095b..e1c5267e7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
 ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+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
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
 
 # Keep this rule in sync with that in `am/guilec'.
@@ -403,7 +407,10 @@ NOCOMP_SOURCES =				\
   ice-9/r7rs-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 925726f5c..a8cb08874 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
@@ -53,4 +53,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 000000000..717d74bfa
--- /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 000000000..684873587
--- /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 000000000..f7ce2e383
--- /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 000000000..f8131ebcf
--- /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 cdaab140f..000000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1044 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;;   Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
-;;
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-;;
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-;;
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-(cond-expand
- (chicken
-  (require-extension syntax-case))
- (guile-2
-  (use-modules (srfi srfi-9)
-               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
-               ;; with either Guile's native exceptions or R6RS exceptions.
-               ;;(srfi srfi-34) (srfi srfi-35)
-               (srfi srfi-39)))
- (guile
-  (use-modules (ice-9 syncase) (srfi srfi-9)
-	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
-	       (srfi srfi-39)))
- (sisc
-  (require-extension (srfi 9 34 35 39)))
- (kawa
-  (module-compile-options warn-undefined-variable: #t
-			  warn-invoke-unknown-method: #t)
-  (provide 'srfi-64)
-  (provide 'testing)
-  (require 'srfi-34)
-  (require 'srfi-35))
- (else ()
-  ))
-
-(cond-expand
- (kawa
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export test-begin . other-names)
-       (module-export %test-begin . other-names)))))
- (else
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index setter getter) ...)
-       (define-record-type test-runner
-	 (alloc)
-	 runner?
-	 (name setter getter) ...)))))
- (else
-  (define %test-runner-cookie (list "test-runner"))
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index getter setter) ...)
-       (begin
-	 (define (runner? obj)
-	   (and (vector? obj)
-		(> (vector-length obj) 1)
-		(eq (vector-ref obj 0) %test-runner-cookie)))
-	 (define (alloc)
-	   (let ((runner (make-vector 23)))
-	     (vector-set! runner 0 %test-runner-cookie)
-	     runner))
-	 (begin
-	   (define (getter runner)
-	     (vector-ref runner index)) ...)
-	 (begin
-	   (define (setter runner value)
-	     (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
-  (test-result-alist! runner '())
-  (test-runner-pass-count! runner 0)
-  (test-runner-fail-count! runner 0)
-  (test-runner-xpass-count! runner 0)
-  (test-runner-xfail-count! runner 0)
-  (test-runner-skip-count! runner 0)
-  (%test-runner-total-count! runner 0)
-  (%test-runner-count-list! runner '())
-  (%test-runner-run-list! runner #t)
-  (%test-runner-skip-list! runner '())
-  (%test-runner-fail-list! runner '())
-  (%test-runner-skip-save! runner '())
-  (%test-runner-fail-save! runner '())
-  (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
-  (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
-    (test-runner-on-group-end! runner %test-null-callback)
-    (test-runner-on-final! runner %test-null-callback)
-    (test-runner-on-test-begin! runner %test-null-callback)
-    (test-runner-on-test-end! runner %test-null-callback)
-    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
-    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
-    runner))
-
-;; Not part of the specification.  FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner test-on-group-begin-simple)
-    (test-runner-on-group-end! runner test-on-group-end-simple)
-    (test-runner-on-final! runner test-on-final-simple)
-    (test-runner-on-test-begin! runner test-on-test-begin-simple)
-    (test-runner-on-test-end! runner test-on-test-end-simple)
-    (test-runner-on-bad-count! runner test-on-bad-count-simple)
-    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
-    runner))
-
-(cond-expand
- (srfi-39
-  (define test-runner-current (make-parameter #f))
-  (define test-runner-factory (make-parameter test-runner-simple)))
- (else
-  (define %test-runner-current #f)
-  (define-syntax test-runner-current
-    (syntax-rules ()
-      ((test-runner-current)
-       %test-runner-current)
-      ((test-runner-current runner)
-       (set! %test-runner-current runner))))
-  (define %test-runner-factory test-runner-simple)
-  (define-syntax test-runner-factory
-    (syntax-rules ()
-      ((test-runner-factory)
-       %test-runner-factory)
-      ((test-runner-factory runner)
-       (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
-  (let ((r (test-runner-current)))
-    (if (not r)
-	(cond-expand
-	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
-	 (else #t)))
-    r))
-
-(define (%test-specifier-matches spec runner)
-  (spec runner))
-
-(define (test-runner-create)
-  ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
-  (let ((result #f))
-    (let loop ((l list))
-      (cond ((null? l) result)
-	    (else
-	     (if (%test-specifier-matches (car l) runner)
-		 (set! result #t))
-	     (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
-  (let ((run (%test-runner-run-list runner)))
-    (cond ((or
-	    (not (or (eqv? run #t)
-		     (%test-any-specifier-matches run runner)))
-	    (%test-any-specifier-matches
-	     (%test-runner-skip-list runner)
-	     runner))
-	    (test-result-set! runner 'result-kind 'skip)
-	    #f)
-	  ((%test-any-specifier-matches
-	    (%test-runner-fail-list runner)
-	    runner)
-	   (test-result-set! runner 'result-kind 'xfail)
-	   'xfail)
-	  (else #t))))
-
-(define (%test-begin suite-name count)
-  (if (not (test-runner-current))
-      (let ((r (test-runner-create)))
-	(test-runner-current r)
-	(test-runner-on-final! r
-	  (let ((old-final (test-runner-on-final r)))
-	    (lambda (r) (old-final r) (test-runner-current #f))))))
-  (let ((runner (test-runner-current)))
-    ((test-runner-on-group-begin runner) runner suite-name count)
-    (%test-runner-skip-save! runner
-			       (cons (%test-runner-skip-list runner)
-				     (%test-runner-skip-save runner)))
-    (%test-runner-fail-save! runner
-			       (cons (%test-runner-fail-list runner)
-				     (%test-runner-fail-save runner)))
-    (%test-runner-count-list! runner
-			     (cons (cons (%test-runner-total-count runner)
-					 count)
-				   (%test-runner-count-list runner)))
-    (test-runner-group-stack! runner (cons suite-name
-					(test-runner-group-stack runner)))))
-(cond-expand
- (kawa
-  ;; Kawa has test-begin built in, implemented as:
-  ;; (begin
-  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
-  ;;   (%test-begin suite-name [count]))
-  ;; This puts test-begin but only test-begin in the default environment.,
-  ;; which makes normal test suites loadable without non-portable commands.
-  )
- (else
-  (define-syntax test-begin
-    (syntax-rules ()
-      ((test-begin suite-name)
-       (%test-begin suite-name #f))
-      ((test-begin suite-name count)
-       (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
-  (if (null? (test-runner-group-stack runner))
-      (begin
-	(display "%%%% Starting test ")
-	(display suite-name)
-	(if test-log-to-file
-	    (let* ((log-file-name
-		    (if (string? test-log-to-file) test-log-to-file
-			(string-append suite-name ".log")))
-		   (log-file
-		    (cond-expand (mzscheme
-				  (open-output-file log-file-name 'truncate/replace))
-				 (else (open-output-file log-file-name)))))
-	      (display "%%%% Starting test " log-file)
-	      (display suite-name log-file)
-	      (newline log-file)
-	      (test-runner-aux-value! runner log-file)
-	      (display "  (Writing full log to \"")
-	      (display log-file-name)
-	      (display "\")")))
-	(newline)))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group begin: " log)
-	  (display suite-name log)
-	  (newline log))))
-  #f)
-
-(define (test-on-group-end-simple runner)
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group end: " log)
-	  (display (car (test-runner-group-stack runner)) log)
-	  (newline log))))
-  #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
-  (display "*** Total number of tests was " port)
-  (display count port)
-  (display " but should be " port)
-  (display expected-count port)
-  (display ". ***" port)
-  (newline port)
-  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
-  (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
-  (%test-on-bad-count-write runner count expected-count (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
-  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
-			    " does not match test-begin " end-name)))
-    (cond-expand
-     (srfi-23 (error msg))
-     (else (display msg) (newline)))))
-  
-
-(define (%test-final-report1 value label port)
-  (if (> value 0)
-      (begin
-	(display label port)
-	(display value port)
-	(newline port))))
-
-(define (%test-final-report-simple runner port)
-  (%test-final-report1 (test-runner-pass-count runner)
-		      "# of expected passes      " port)
-  (%test-final-report1 (test-runner-xfail-count runner)
-		      "# of expected failures    " port)
-  (%test-final-report1 (test-runner-xpass-count runner)
-		      "# of unexpected successes " port)
-  (%test-final-report1 (test-runner-fail-count runner)
-		      "# of unexpected failures  " port)
-  (%test-final-report1 (test-runner-skip-count runner)
-		      "# of skipped tests        " port))
-
-(define (test-on-final-simple runner)
-  (%test-final-report-simple runner (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
-   (let* ((line-info (test-result-alist runner))
-	  (source-file (assq 'source-file line-info))
-	  (source-line (assq 'source-line line-info))
-	  (file (if source-file (cdr source-file) "")))
-     (if source-line
-	 (string-append file ":"
-			(number->string (cdr source-line)) ": ")
-	 "")))
-
-(define (%test-end suite-name line-info)
-  (let* ((r (test-runner-get))
-	 (groups (test-runner-group-stack r))
-	 (line (%test-format-line r)))
-    (test-result-alist! r line-info)
-    (if (null? groups)
-	(let ((msg (string-append line "test-end not in a group")))
-	  (cond-expand
-	   (srfi-23 (error msg))
-	   (else (display msg) (newline)))))
-    (if (and suite-name (not (equal? suite-name (car groups))))
-	((test-runner-on-bad-end-name r) r suite-name (car groups)))
-    (let* ((count-list (%test-runner-count-list r))
-	   (expected-count (cdar count-list))
-	   (saved-count (caar count-list))
-	   (group-count (- (%test-runner-total-count r) saved-count)))
-      (if (and expected-count
-	       (not (= expected-count group-count)))
-	  ((test-runner-on-bad-count r) r group-count expected-count))
-      ((test-runner-on-group-end r) r)
-      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
-      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
-      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
-      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
-      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
-      (%test-runner-count-list! r (cdr count-list))
-      (if (null? (test-runner-group-stack r))
-	  ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
-  (syntax-rules ()
-    ((test-group suite-name . body)
-     (let ((r (test-runner-current)))
-       ;; Ideally should also set line-number, if available.
-       (test-result-alist! r (list (cons 'test-name suite-name)))
-       (if (%test-should-execute r)
-	   (dynamic-wind
-	       (lambda () (test-begin suite-name))
-	       (lambda () . body)
-	       (lambda () (test-end  suite-name))))))))
-
-(define-syntax test-group-with-cleanup
-  (syntax-rules ()
-    ((test-group-with-cleanup suite-name form cleanup-form)
-     (test-group suite-name
-		    (dynamic-wind
-			(lambda () #f)
-			(lambda () form)
-			(lambda () cleanup-form))))
-    ((test-group-with-cleanup suite-name cleanup-form)
-     (test-group-with-cleanup suite-name #f cleanup-form))
-    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
-     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (source-form (assq 'source-form results))
-	       (test-name (assq 'test-name results)))
-	  (display "Test begin:" log)
-	  (newline log)
-	  (if test-name (%test-write-result1 test-name log))
-	  (if source-file (%test-write-result1 source-file log))
-	  (if source-line (%test-write-result1 source-line log))
-	  (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
-  (syntax-rules ()
-    ((test-result-ref runner pname)
-     (test-result-ref runner pname #f))
-    ((test-result-ref runner pname default)
-     (let ((p (assq pname (test-result-alist runner))))
-       (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
-  (let ((log (test-runner-aux-value runner))
-	(kind (test-result-ref runner 'result-kind)))
-    (if (memq kind '(fail xpass))
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (test-name (assq 'test-name results)))
-	  (if (or source-file source-line)
-	      (begin
-		(if source-file (display (cdr source-file)))
-		(display ":")
-		(if source-line (display (cdr source-line)))
-		(display ": ")))
-	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
-	  (if test-name
-	      (begin
-		(display " ")
-		(display (cdr test-name))))
-	  (newline)))
-    (if (output-port? log)
-	(begin
-	  (display "Test end:" log)
-	  (newline log)
-	  (let loop ((list (test-result-alist runner)))
-	    (if (pair? list)
-		(let ((pair (car list)))
-		  ;; Write out properties not written out by on-test-begin.
-		  (if (not (memq (car pair)
-				 '(test-name source-file source-line source-form)))
-		      (%test-write-result1 pair log))
-		  (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
-  (display "  " port)
-  (display (car pair) port)
-  (display ": " port)
-  (write (cdr pair) port)
-  (newline port))
-
-(define (test-result-set! runner pname value)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(set-cdr! p value)
-	(test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
-  (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(test-result-alist! runner
-				   (let loop ((r alist))
-				     (if (eq? r p) (cdr r)
-					 (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
-    (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
-    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
-  (let* ((r (test-runner-get))
-	 (result-kind (test-result-kind r)))
-    (case result-kind
-      ((pass)
-       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
-      ((fail)
-       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
-      ((xpass)
-       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
-      ((xfail)
-       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
-      (else
-       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
-    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
-    ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (catch #t
-         (lambda () test-expression)
-         (lambda (key . args)
-           (test-result-set! (test-runner-current) 'actual-error
-                             (cons key args))
-           #f))))))
- (kawa
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (try-catch test-expression
-		  (ex <java.lang.Throwable>
-		      (test-result-set! (test-runner-current) 'actual-error ex)
-		      #f))))))
- (srfi-34
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (guard (err (else #f)) test-expression)))))
- (chicken
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (condition-case test-expression (ex () #f))))))
- (else
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       test-expression)))))
-	    
-(cond-expand
- ((or kawa mzscheme)
-  (cond-expand
-   (mzscheme
-    (define-for-syntax (%test-syntax-file form)
-      (let ((source (syntax-source form)))
-	(cond ((string? source) file)
-				((path? source) (path->string source))
-				(else #f)))))
-   (kawa
-    (define (%test-syntax-file form)
-      (syntax-source form))))
-  (define (%test-source-line2 form)
-    (let* ((line (syntax-line form))
-	   (file (%test-syntax-file form))
-	   (line-pair (if line (list (cons 'source-line line)) '())))
-      (cons (cons 'source-form (syntax-object->datum form))
-	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
-  (define (%test-source-line2 form)
-    (let* ((src-props (syntax-source form))
-           (file (and src-props (assq-ref src-props 'filename)))
-           (line (and src-props (assq-ref src-props 'line)))
-           (file-alist (if file
-                           `((source-file . ,file))
-                           '()))
-           (line-alist (if line
-                           `((source-line . ,(+ line 1)))
-                           '())))
-      (datum->syntax (syntax here)
-                     `((source-form . ,(syntax->datum form))
-                       ,@file-alist
-                       ,@line-alist)))))
- (else
-  (define (%test-source-line2 form)
-    '())))
-
-(define (%test-on-test-begin r)
-  (%test-should-execute r)
-  ((test-runner-on-test-begin r) r)
-  (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
-    (test-result-set! r 'result-kind
-		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
-			  (if result 'xpass 'xfail)
-			  (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
-  (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
-  (syntax-rules ()
-		((%test-comp2body r comp expected expr)
-		 (let ()
-		   (if (%test-on-test-begin r)
-		       (let ((exp expected))
-			 (test-result-set! r 'expected-value exp)
-			 (let ((res (%test-evaluate-with-catch expr)))
-			   (test-result-set! r 'actual-value res)
-			   (%test-on-test-end r (comp exp res)))))
-		   (%test-report-result)))))
-
-(define (%test-approximate= error)
-  (lambda (value expected)
-    (let ((rval (real-part value))
-          (ival (imag-part value))
-          (rexp (real-part expected))
-          (iexp (imag-part expected)))
-      (and (>= rval (- rexp error))
-           (>= ival (- iexp error))
-           (<= rval (+ rexp error))
-           (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
-  (syntax-rules ()
-    ((%test-comp1body r expr)
-     (let ()
-       (if (%test-on-test-begin r)
-	   (let ()
-	     (let ((res (%test-evaluate-with-catch expr)))
-	       (test-result-set! r 'actual-value res)
-	       (%test-on-test-end r res))))
-       (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-  ;; Should be made to work for any Scheme with syntax-case
-  ;; However, I haven't gotten the quoting working.  FIXME.
-  (define-syntax test-end
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac suite-name) line)
-	 (syntax
-	  (%test-end suite-name line)))
-	(((mac) line)
-	 (syntax
-	  (%test-end #f line))))))
-  (define-syntax test-assert
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-comp1body r expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-comp1body r expr)))))))
-  (define (%test-comp2 comp x)
-    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
-      (((mac tname expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r comp expected expr))))
-      (((mac expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r comp expected expr))))))
-  (define-syntax test-eqv
-    (lambda (x) (%test-comp2 (syntax eqv?) x)))
-  (define-syntax test-eq
-    (lambda (x) (%test-comp2 (syntax eq?) x)))
-  (define-syntax test-equal
-    (lambda (x) (%test-comp2 (syntax equal?) x)))
-  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-      (((mac tname expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r (%test-approximate= error) expected expr))))
-      (((mac expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
-  (define-syntax test-end
-    (syntax-rules ()
-      ((test-end)
-       (%test-end #f '()))
-      ((test-end suite-name)
-       (%test-end suite-name '()))))
-  (define-syntax test-assert
-    (syntax-rules ()
-      ((test-assert tname test-expression)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r '((test-name . tname)))
-	 (%test-comp1body r test-expression)))
-      ((test-assert test-expression)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp1body r test-expression)))))
-  (define-syntax %test-comp2
-    (syntax-rules ()
-      ((%test-comp2 comp tname expected expr)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r (list (cons 'test-name tname)))
-	 (%test-comp2body r comp expected expr)))
-      ((%test-comp2 comp expected expr)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp2body r comp expected expr)))))
-  (define-syntax test-equal
-    (syntax-rules ()
-      ((test-equal . rest)
-       (%test-comp2 equal? . rest))))
-  (define-syntax test-eqv
-    (syntax-rules ()
-      ((test-eqv . rest)
-       (%test-comp2 eqv? . rest))))
-  (define-syntax test-eq
-    (syntax-rules ()
-      ((test-eq . rest)
-       (%test-comp2 eq? . rest))))
-  (define-syntax test-approximate
-    (syntax-rules ()
-      ((test-approximate tname expected expr error)
-       (%test-comp2 (%test-approximate= error) tname expected expr))
-      ((test-approximate expected expr error)
-       (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (cond ((%test-on-test-begin r)
-              (let ((et etype))
-                (test-result-set! r 'expected-error et)
-                (%test-on-test-end r
-                                   (catch #t
-                                     (lambda ()
-                                       (test-result-set! r 'actual-value expr)
-                                       #f)
-                                     (lambda (key . args)
-                                       ;; TODO: decide how to specify expected
-                                       ;; error types for Guile.
-                                       (test-result-set! r 'actual-error
-                                                         (cons key args))
-                                       #t)))
-                (%test-report-result))))))))
- (mzscheme
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
-					 (let ()
-					   (test-result-set! r 'actual-value expr)
-					   #f)))))))
- (chicken
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-        (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r #t expr)
-       (cond ((%test-on-test-begin r)
-	      (test-result-set! r 'expected-error #t)
-	      (%test-on-test-end r
-				 (try-catch
-				  (let ()
-				    (test-result-set! r 'actual-value expr)
-				    #f)
-				  (ex <java.lang.Throwable>
-				      (test-result-set! r 'actual-error ex)
-				      #t)))
-	      (%test-report-result))))
-      ((%test-error r etype expr)
-       (if (%test-on-test-begin r)
-	   (let ((et etype))
-	     (test-result-set! r 'expected-error et)
-	     (%test-on-test-end r
-				(try-catch
-				 (let ()
-				   (test-result-set! r 'actual-value expr)
-				   #f)
-				 (ex <java.lang.Throwable>
-				     (test-result-set! r 'actual-error ex)
-				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
-						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
-					    (instance? ex et))
-					   (else #t)))))
-	     (%test-report-result)))))))
- ((and srfi-34 srfi-35)
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex ((condition-type? etype)
-		   (and (condition? ex) (condition-has-type? ex etype)))
-		  ((procedure? etype)
-		   (etype ex))
-		  ((equal? etype #t)
-		   #t)
-		  (else #t))
-	      expr #f))))))
- (srfi-34
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (begin
-	 ((test-runner-on-test-begin r) r)
-	 (test-result-set! r 'result-kind 'skip)
-	 (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
-  (define-syntax test-error
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-error r etype expr))))
-	(((mac etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r etype expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r #t expr))))))))
- (else
-  (define-syntax test-error
-    (syntax-rules ()
-      ((test-error name etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r `((test-name . ,name)))
-         (%test-error r etype expr)))
-      ((test-error etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r etype expr)))
-      ((test-error expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
-  (if (test-runner? first)
-      (test-with-runner first (apply test-apply rest))
-      (let ((r (test-runner-current)))
-	(if r
-	    (let ((run-list (%test-runner-run-list r)))
-	      (cond ((null? rest)
-		     (%test-runner-run-list! r (reverse run-list))
-		     (first)) ;; actually apply procedure thunk
-		    (else
-		     (%test-runner-run-list!
-		      r
-		      (if (eq? run-list #t) (list first) (cons first run-list)))
-		     (apply test-apply rest)
-		     (%test-runner-run-list! r run-list))))
-	    (let ((r (test-runner-create)))
-	      (test-with-runner r (apply test-apply first rest))
-	      ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
-  (syntax-rules ()
-    ((test-with-runner runner form ...)
-     (let ((saved-runner (test-runner-current)))
-       (dynamic-wind
-           (lambda () (test-runner-current runner))
-           (lambda () form ...)
-           (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
-  (let ((i 0))
-    (lambda (runner)
-      (set! i (+ i 1))
-      (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
-  (syntax-rules ()
-    ((test-match-nth n)
-     (test-match-nth n 1))
-    ((test-match-nth n count)
-     (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
-  (lambda (runner)
-    (let ((result #t))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if (not ((car l) runner))
-		  (set! result #f))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-all
-  (syntax-rules ()
-    ((test-match-all pred ...)
-     (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
-  (lambda (runner)
-    (let ((result #f))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if ((car l) runner)
-		  (set! result #t))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-any
-  (syntax-rules ()
-    ((test-match-any pred ...)
-     (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
-  (cond ((procedure? specifier) specifier)
-	((integer? specifier) (test-match-nth 1 specifier))
-	((string? specifier) (test-match-name specifier))
-	(else
-	 (error "not a valid test specifier"))))
-
-(define-syntax test-skip
-  (syntax-rules ()
-    ((test-skip pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-skip-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
-  (syntax-rules ()
-    ((test-expect-fail pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-fail-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
-  (lambda (runner)
-    (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
-  (let* ((port (open-input-string string))
-	 (form (read port)))
-    (if (eof-object? (read-char port))
-	(cond-expand
-	 (guile (eval form (current-module)))
-	 (else (eval form)))
-	(cond-expand
-	 (srfi-23 (error "(not at eof)"))
-	 (else "error")))))
-
-- 
2.30.2


[-- Attachment #3: 0002-Augment-SRFI-64-test-suite.patch --]
[-- Type: text/plain, Size: 1901 bytes --]

From 5f7b1e3790f3941a12326aec10f90ca55fe0e1c3 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:26:10 +0200
Subject: [PATCH 2/2] Augment SRFI-64 test-suite.

* test-suite/tests/srfi-64-test.scm ("1.3. test-approximate"): New
  section.
("2.1.4. FAIL with a test name and error type"):
("2.1.5. PASS with an error type but no name"):
("2.1.6. FAIL with an error type but no name"): New tests.
---
 test-suite/tests/srfi-64-test.scm | 37 +++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..b7f6d2934 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -167,6 +167,19 @@
 
 (test-end);1.2
 
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-approximate "a" (mean 3 5) 4   0.001)
+    (test-approximate "b" (mean 3 5) 4.5 0.001)
+    (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
 (test-end "1. Simple test-cases")
 
 ;;;
@@ -202,6 +215,30 @@
     ;; PASS
     (test-error "a" #t (vector-ref '#(1 2) 9)))))
 
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error #t (vector-ref '#(1 2) 0)))))
+
 (test-end "2.1. test-error")
 
 (test-end "2. Tests for catching errors")
-- 
2.30.2


^ permalink raw reply related	[flat|nested] 6+ messages in thread

* Re: [PATCHES] Use a better SRFI-64 implementation.
  2021-05-10 18:25 [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
  2021-05-11 11:32 ` Taylan Kammer
@ 2021-05-11 14:32 ` Taylan Kammer
  2021-05-11 19:39 ` Taylan Kammer
  2 siblings, 0 replies; 6+ messages in thread
From: Taylan Kammer @ 2021-05-11 14:32 UTC (permalink / raw)
  To: guile-devel

On 10.05.2021 20:25, Taylan Kammer wrote:
> 
> - Improved expand-time performance for large test suites
> 

I thought it would be a good idea to quantify this, so I
benchmarked the compilation performance of a test suite
of 289 tests (that of the scheme-bytsetructures library),
and had the following results.

The first three compilations are with stock Guile 3.0.7,
and the latter three are with the patch that replaces
the SRFI-64 implementation applied to 3.0.7.


=== snip ===

$ touch run-tests.guile.scm && time /opt/guile-3.0.7/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m9.465s
user	0m12.787s
sys	0m2.179s

$ touch run-tests.guile.scm && time /opt/guile-3.0.7/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m9.419s
user	0m12.988s
sys	0m1.842s

$ touch run-tests.guile.scm && time /opt/guile-3.0.7/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m9.387s
user	0m13.132s
sys	0m1.656s

$ touch run-tests.guile.scm && time /opt/guile-master/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m4.371s
user	0m5.903s
sys	0m1.239s

$ touch run-tests.guile.scm && time /opt/guile-master/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m4.556s
user	0m6.836s
sys	0m1.502s

$ touch run-tests.guile.scm && time /opt/guile-master/bin/guild compile -L . run-tests.guile.scm 
wrote `.../run-tests.guile.scm.go'

real	0m4.493s
user	0m6.273s
sys	0m1.767s

=== /snip ===


As you can see, the time to compile the test suite is cut in half.


Here's the test suite used for the benchmark:

https://github.com/TaylanUB/scheme-bytestructures/blob/master/run-tests.body.scm

(That file is included from run-test.guile.scm.)


- Taylan



^ permalink raw reply	[flat|nested] 6+ messages in thread

* Re: [PATCHES] Use a better SRFI-64 implementation.
  2021-05-11 11:32 ` Taylan Kammer
@ 2021-05-11 19:14   ` Taylan Kammer
  2021-05-11 20:52     ` Taylan Kammer
  0 siblings, 1 reply; 6+ messages in thread
From: Taylan Kammer @ 2021-05-11 19:14 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 859 bytes --]

On 11.05.2021 13:32, Taylan Kammer wrote:
> 
> Here's a fixed patch-set.
> 

And here's another minimally changed one.  Sorry about the noise,
but you know how it goes: you publish something to the public, and
soon after notice another edge or two to polish. :-)

The module definition used to include "#:declarative #f" which I've now
removed as it wasn't necessary anymore.

Apparently it was necessary due to a non-standard global variable exposed
by the old implementation, called test-log-to-file.

It was possible to set this to #f to disable logging.  I'm not sure if
anyone ever used that, but with the new implementation you can achieve
the same by executing:

  (test-runner-current (test-runner-simple))

As an additional extension, you can now also provide a file name argument
to test-runner-simple to change the name of the log file.


- Taylan

[-- Attachment #2: 0001-Use-a-different-SRFI-64-implementation.patch --]
[-- Type: text/plain, Size: 76004 bytes --]

From 55f2e4f3bcf9c1b26527f39b6725f44aa4ca635a Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:23:17 +0200
Subject: [PATCH 1/2] Use a different 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                       |   17 +-
 module/srfi/srfi-64/execution.body.scm        |  424 +++++++
 module/srfi/srfi-64/source-info.body.scm      |   88 ++
 .../srfi/srfi-64/test-runner-simple.body.scm  |  173 +++
 module/srfi/srfi-64/test-runner.body.scm      |  165 +++
 module/srfi/srfi-64/testing.scm               | 1044 -----------------
 7 files changed, 872 insertions(+), 1050 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 41b77095b..e1c5267e7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
 ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+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
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
 
 # Keep this rule in sync with that in `am/guilec'.
@@ -403,7 +407,10 @@ NOCOMP_SOURCES =				\
   ice-9/r7rs-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 925726f5c..e6c6ce80a 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
@@ -48,9 +48,18 @@
    test-on-group-begin-simple test-on-group-end-simple
    test-on-bad-count-simple test-on-bad-end-name-simple
    test-on-final-simple test-on-test-end-simple
-   test-on-final-simple)
-  #:declarative? #f) ; #f needed for test-log-to-file
+   test-on-final-simple))
 
 (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 000000000..10dd3c7e0
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,424 @@
+;; 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 ((log-file (string-append suite-name ".srfi64.log")))
+      (test-runner-current (test-runner-simple log-file)))))
+
+(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 000000000..684873587
--- /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 000000000..870b314dc
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,173 @@
+;; 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
+  (case-lambda
+   (()
+    (test-runner-simple #f))
+   ((log-file)
+    (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)
+      (%test-runner-log-file!          runner log-file)
+      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 000000000..f8131ebcf
--- /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 cdaab140f..000000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1044 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;;   Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
-;;
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-;;
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-;;
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-(cond-expand
- (chicken
-  (require-extension syntax-case))
- (guile-2
-  (use-modules (srfi srfi-9)
-               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
-               ;; with either Guile's native exceptions or R6RS exceptions.
-               ;;(srfi srfi-34) (srfi srfi-35)
-               (srfi srfi-39)))
- (guile
-  (use-modules (ice-9 syncase) (srfi srfi-9)
-	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
-	       (srfi srfi-39)))
- (sisc
-  (require-extension (srfi 9 34 35 39)))
- (kawa
-  (module-compile-options warn-undefined-variable: #t
-			  warn-invoke-unknown-method: #t)
-  (provide 'srfi-64)
-  (provide 'testing)
-  (require 'srfi-34)
-  (require 'srfi-35))
- (else ()
-  ))
-
-(cond-expand
- (kawa
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export test-begin . other-names)
-       (module-export %test-begin . other-names)))))
- (else
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index setter getter) ...)
-       (define-record-type test-runner
-	 (alloc)
-	 runner?
-	 (name setter getter) ...)))))
- (else
-  (define %test-runner-cookie (list "test-runner"))
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index getter setter) ...)
-       (begin
-	 (define (runner? obj)
-	   (and (vector? obj)
-		(> (vector-length obj) 1)
-		(eq (vector-ref obj 0) %test-runner-cookie)))
-	 (define (alloc)
-	   (let ((runner (make-vector 23)))
-	     (vector-set! runner 0 %test-runner-cookie)
-	     runner))
-	 (begin
-	   (define (getter runner)
-	     (vector-ref runner index)) ...)
-	 (begin
-	   (define (setter runner value)
-	     (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
-  (test-result-alist! runner '())
-  (test-runner-pass-count! runner 0)
-  (test-runner-fail-count! runner 0)
-  (test-runner-xpass-count! runner 0)
-  (test-runner-xfail-count! runner 0)
-  (test-runner-skip-count! runner 0)
-  (%test-runner-total-count! runner 0)
-  (%test-runner-count-list! runner '())
-  (%test-runner-run-list! runner #t)
-  (%test-runner-skip-list! runner '())
-  (%test-runner-fail-list! runner '())
-  (%test-runner-skip-save! runner '())
-  (%test-runner-fail-save! runner '())
-  (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
-  (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
-    (test-runner-on-group-end! runner %test-null-callback)
-    (test-runner-on-final! runner %test-null-callback)
-    (test-runner-on-test-begin! runner %test-null-callback)
-    (test-runner-on-test-end! runner %test-null-callback)
-    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
-    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
-    runner))
-
-;; Not part of the specification.  FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner test-on-group-begin-simple)
-    (test-runner-on-group-end! runner test-on-group-end-simple)
-    (test-runner-on-final! runner test-on-final-simple)
-    (test-runner-on-test-begin! runner test-on-test-begin-simple)
-    (test-runner-on-test-end! runner test-on-test-end-simple)
-    (test-runner-on-bad-count! runner test-on-bad-count-simple)
-    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
-    runner))
-
-(cond-expand
- (srfi-39
-  (define test-runner-current (make-parameter #f))
-  (define test-runner-factory (make-parameter test-runner-simple)))
- (else
-  (define %test-runner-current #f)
-  (define-syntax test-runner-current
-    (syntax-rules ()
-      ((test-runner-current)
-       %test-runner-current)
-      ((test-runner-current runner)
-       (set! %test-runner-current runner))))
-  (define %test-runner-factory test-runner-simple)
-  (define-syntax test-runner-factory
-    (syntax-rules ()
-      ((test-runner-factory)
-       %test-runner-factory)
-      ((test-runner-factory runner)
-       (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
-  (let ((r (test-runner-current)))
-    (if (not r)
-	(cond-expand
-	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
-	 (else #t)))
-    r))
-
-(define (%test-specifier-matches spec runner)
-  (spec runner))
-
-(define (test-runner-create)
-  ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
-  (let ((result #f))
-    (let loop ((l list))
-      (cond ((null? l) result)
-	    (else
-	     (if (%test-specifier-matches (car l) runner)
-		 (set! result #t))
-	     (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
-  (let ((run (%test-runner-run-list runner)))
-    (cond ((or
-	    (not (or (eqv? run #t)
-		     (%test-any-specifier-matches run runner)))
-	    (%test-any-specifier-matches
-	     (%test-runner-skip-list runner)
-	     runner))
-	    (test-result-set! runner 'result-kind 'skip)
-	    #f)
-	  ((%test-any-specifier-matches
-	    (%test-runner-fail-list runner)
-	    runner)
-	   (test-result-set! runner 'result-kind 'xfail)
-	   'xfail)
-	  (else #t))))
-
-(define (%test-begin suite-name count)
-  (if (not (test-runner-current))
-      (let ((r (test-runner-create)))
-	(test-runner-current r)
-	(test-runner-on-final! r
-	  (let ((old-final (test-runner-on-final r)))
-	    (lambda (r) (old-final r) (test-runner-current #f))))))
-  (let ((runner (test-runner-current)))
-    ((test-runner-on-group-begin runner) runner suite-name count)
-    (%test-runner-skip-save! runner
-			       (cons (%test-runner-skip-list runner)
-				     (%test-runner-skip-save runner)))
-    (%test-runner-fail-save! runner
-			       (cons (%test-runner-fail-list runner)
-				     (%test-runner-fail-save runner)))
-    (%test-runner-count-list! runner
-			     (cons (cons (%test-runner-total-count runner)
-					 count)
-				   (%test-runner-count-list runner)))
-    (test-runner-group-stack! runner (cons suite-name
-					(test-runner-group-stack runner)))))
-(cond-expand
- (kawa
-  ;; Kawa has test-begin built in, implemented as:
-  ;; (begin
-  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
-  ;;   (%test-begin suite-name [count]))
-  ;; This puts test-begin but only test-begin in the default environment.,
-  ;; which makes normal test suites loadable without non-portable commands.
-  )
- (else
-  (define-syntax test-begin
-    (syntax-rules ()
-      ((test-begin suite-name)
-       (%test-begin suite-name #f))
-      ((test-begin suite-name count)
-       (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
-  (if (null? (test-runner-group-stack runner))
-      (begin
-	(display "%%%% Starting test ")
-	(display suite-name)
-	(if test-log-to-file
-	    (let* ((log-file-name
-		    (if (string? test-log-to-file) test-log-to-file
-			(string-append suite-name ".log")))
-		   (log-file
-		    (cond-expand (mzscheme
-				  (open-output-file log-file-name 'truncate/replace))
-				 (else (open-output-file log-file-name)))))
-	      (display "%%%% Starting test " log-file)
-	      (display suite-name log-file)
-	      (newline log-file)
-	      (test-runner-aux-value! runner log-file)
-	      (display "  (Writing full log to \"")
-	      (display log-file-name)
-	      (display "\")")))
-	(newline)))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group begin: " log)
-	  (display suite-name log)
-	  (newline log))))
-  #f)
-
-(define (test-on-group-end-simple runner)
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group end: " log)
-	  (display (car (test-runner-group-stack runner)) log)
-	  (newline log))))
-  #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
-  (display "*** Total number of tests was " port)
-  (display count port)
-  (display " but should be " port)
-  (display expected-count port)
-  (display ". ***" port)
-  (newline port)
-  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
-  (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
-  (%test-on-bad-count-write runner count expected-count (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
-  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
-			    " does not match test-begin " end-name)))
-    (cond-expand
-     (srfi-23 (error msg))
-     (else (display msg) (newline)))))
-  
-
-(define (%test-final-report1 value label port)
-  (if (> value 0)
-      (begin
-	(display label port)
-	(display value port)
-	(newline port))))
-
-(define (%test-final-report-simple runner port)
-  (%test-final-report1 (test-runner-pass-count runner)
-		      "# of expected passes      " port)
-  (%test-final-report1 (test-runner-xfail-count runner)
-		      "# of expected failures    " port)
-  (%test-final-report1 (test-runner-xpass-count runner)
-		      "# of unexpected successes " port)
-  (%test-final-report1 (test-runner-fail-count runner)
-		      "# of unexpected failures  " port)
-  (%test-final-report1 (test-runner-skip-count runner)
-		      "# of skipped tests        " port))
-
-(define (test-on-final-simple runner)
-  (%test-final-report-simple runner (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
-   (let* ((line-info (test-result-alist runner))
-	  (source-file (assq 'source-file line-info))
-	  (source-line (assq 'source-line line-info))
-	  (file (if source-file (cdr source-file) "")))
-     (if source-line
-	 (string-append file ":"
-			(number->string (cdr source-line)) ": ")
-	 "")))
-
-(define (%test-end suite-name line-info)
-  (let* ((r (test-runner-get))
-	 (groups (test-runner-group-stack r))
-	 (line (%test-format-line r)))
-    (test-result-alist! r line-info)
-    (if (null? groups)
-	(let ((msg (string-append line "test-end not in a group")))
-	  (cond-expand
-	   (srfi-23 (error msg))
-	   (else (display msg) (newline)))))
-    (if (and suite-name (not (equal? suite-name (car groups))))
-	((test-runner-on-bad-end-name r) r suite-name (car groups)))
-    (let* ((count-list (%test-runner-count-list r))
-	   (expected-count (cdar count-list))
-	   (saved-count (caar count-list))
-	   (group-count (- (%test-runner-total-count r) saved-count)))
-      (if (and expected-count
-	       (not (= expected-count group-count)))
-	  ((test-runner-on-bad-count r) r group-count expected-count))
-      ((test-runner-on-group-end r) r)
-      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
-      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
-      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
-      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
-      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
-      (%test-runner-count-list! r (cdr count-list))
-      (if (null? (test-runner-group-stack r))
-	  ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
-  (syntax-rules ()
-    ((test-group suite-name . body)
-     (let ((r (test-runner-current)))
-       ;; Ideally should also set line-number, if available.
-       (test-result-alist! r (list (cons 'test-name suite-name)))
-       (if (%test-should-execute r)
-	   (dynamic-wind
-	       (lambda () (test-begin suite-name))
-	       (lambda () . body)
-	       (lambda () (test-end  suite-name))))))))
-
-(define-syntax test-group-with-cleanup
-  (syntax-rules ()
-    ((test-group-with-cleanup suite-name form cleanup-form)
-     (test-group suite-name
-		    (dynamic-wind
-			(lambda () #f)
-			(lambda () form)
-			(lambda () cleanup-form))))
-    ((test-group-with-cleanup suite-name cleanup-form)
-     (test-group-with-cleanup suite-name #f cleanup-form))
-    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
-     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (source-form (assq 'source-form results))
-	       (test-name (assq 'test-name results)))
-	  (display "Test begin:" log)
-	  (newline log)
-	  (if test-name (%test-write-result1 test-name log))
-	  (if source-file (%test-write-result1 source-file log))
-	  (if source-line (%test-write-result1 source-line log))
-	  (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
-  (syntax-rules ()
-    ((test-result-ref runner pname)
-     (test-result-ref runner pname #f))
-    ((test-result-ref runner pname default)
-     (let ((p (assq pname (test-result-alist runner))))
-       (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
-  (let ((log (test-runner-aux-value runner))
-	(kind (test-result-ref runner 'result-kind)))
-    (if (memq kind '(fail xpass))
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (test-name (assq 'test-name results)))
-	  (if (or source-file source-line)
-	      (begin
-		(if source-file (display (cdr source-file)))
-		(display ":")
-		(if source-line (display (cdr source-line)))
-		(display ": ")))
-	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
-	  (if test-name
-	      (begin
-		(display " ")
-		(display (cdr test-name))))
-	  (newline)))
-    (if (output-port? log)
-	(begin
-	  (display "Test end:" log)
-	  (newline log)
-	  (let loop ((list (test-result-alist runner)))
-	    (if (pair? list)
-		(let ((pair (car list)))
-		  ;; Write out properties not written out by on-test-begin.
-		  (if (not (memq (car pair)
-				 '(test-name source-file source-line source-form)))
-		      (%test-write-result1 pair log))
-		  (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
-  (display "  " port)
-  (display (car pair) port)
-  (display ": " port)
-  (write (cdr pair) port)
-  (newline port))
-
-(define (test-result-set! runner pname value)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(set-cdr! p value)
-	(test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
-  (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(test-result-alist! runner
-				   (let loop ((r alist))
-				     (if (eq? r p) (cdr r)
-					 (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
-    (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
-    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
-  (let* ((r (test-runner-get))
-	 (result-kind (test-result-kind r)))
-    (case result-kind
-      ((pass)
-       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
-      ((fail)
-       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
-      ((xpass)
-       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
-      ((xfail)
-       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
-      (else
-       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
-    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
-    ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (catch #t
-         (lambda () test-expression)
-         (lambda (key . args)
-           (test-result-set! (test-runner-current) 'actual-error
-                             (cons key args))
-           #f))))))
- (kawa
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (try-catch test-expression
-		  (ex <java.lang.Throwable>
-		      (test-result-set! (test-runner-current) 'actual-error ex)
-		      #f))))))
- (srfi-34
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (guard (err (else #f)) test-expression)))))
- (chicken
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (condition-case test-expression (ex () #f))))))
- (else
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       test-expression)))))
-	    
-(cond-expand
- ((or kawa mzscheme)
-  (cond-expand
-   (mzscheme
-    (define-for-syntax (%test-syntax-file form)
-      (let ((source (syntax-source form)))
-	(cond ((string? source) file)
-				((path? source) (path->string source))
-				(else #f)))))
-   (kawa
-    (define (%test-syntax-file form)
-      (syntax-source form))))
-  (define (%test-source-line2 form)
-    (let* ((line (syntax-line form))
-	   (file (%test-syntax-file form))
-	   (line-pair (if line (list (cons 'source-line line)) '())))
-      (cons (cons 'source-form (syntax-object->datum form))
-	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
-  (define (%test-source-line2 form)
-    (let* ((src-props (syntax-source form))
-           (file (and src-props (assq-ref src-props 'filename)))
-           (line (and src-props (assq-ref src-props 'line)))
-           (file-alist (if file
-                           `((source-file . ,file))
-                           '()))
-           (line-alist (if line
-                           `((source-line . ,(+ line 1)))
-                           '())))
-      (datum->syntax (syntax here)
-                     `((source-form . ,(syntax->datum form))
-                       ,@file-alist
-                       ,@line-alist)))))
- (else
-  (define (%test-source-line2 form)
-    '())))
-
-(define (%test-on-test-begin r)
-  (%test-should-execute r)
-  ((test-runner-on-test-begin r) r)
-  (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
-    (test-result-set! r 'result-kind
-		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
-			  (if result 'xpass 'xfail)
-			  (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
-  (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
-  (syntax-rules ()
-		((%test-comp2body r comp expected expr)
-		 (let ()
-		   (if (%test-on-test-begin r)
-		       (let ((exp expected))
-			 (test-result-set! r 'expected-value exp)
-			 (let ((res (%test-evaluate-with-catch expr)))
-			   (test-result-set! r 'actual-value res)
-			   (%test-on-test-end r (comp exp res)))))
-		   (%test-report-result)))))
-
-(define (%test-approximate= error)
-  (lambda (value expected)
-    (let ((rval (real-part value))
-          (ival (imag-part value))
-          (rexp (real-part expected))
-          (iexp (imag-part expected)))
-      (and (>= rval (- rexp error))
-           (>= ival (- iexp error))
-           (<= rval (+ rexp error))
-           (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
-  (syntax-rules ()
-    ((%test-comp1body r expr)
-     (let ()
-       (if (%test-on-test-begin r)
-	   (let ()
-	     (let ((res (%test-evaluate-with-catch expr)))
-	       (test-result-set! r 'actual-value res)
-	       (%test-on-test-end r res))))
-       (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-  ;; Should be made to work for any Scheme with syntax-case
-  ;; However, I haven't gotten the quoting working.  FIXME.
-  (define-syntax test-end
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac suite-name) line)
-	 (syntax
-	  (%test-end suite-name line)))
-	(((mac) line)
-	 (syntax
-	  (%test-end #f line))))))
-  (define-syntax test-assert
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-comp1body r expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-comp1body r expr)))))))
-  (define (%test-comp2 comp x)
-    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
-      (((mac tname expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r comp expected expr))))
-      (((mac expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r comp expected expr))))))
-  (define-syntax test-eqv
-    (lambda (x) (%test-comp2 (syntax eqv?) x)))
-  (define-syntax test-eq
-    (lambda (x) (%test-comp2 (syntax eq?) x)))
-  (define-syntax test-equal
-    (lambda (x) (%test-comp2 (syntax equal?) x)))
-  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-      (((mac tname expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r (%test-approximate= error) expected expr))))
-      (((mac expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
-  (define-syntax test-end
-    (syntax-rules ()
-      ((test-end)
-       (%test-end #f '()))
-      ((test-end suite-name)
-       (%test-end suite-name '()))))
-  (define-syntax test-assert
-    (syntax-rules ()
-      ((test-assert tname test-expression)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r '((test-name . tname)))
-	 (%test-comp1body r test-expression)))
-      ((test-assert test-expression)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp1body r test-expression)))))
-  (define-syntax %test-comp2
-    (syntax-rules ()
-      ((%test-comp2 comp tname expected expr)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r (list (cons 'test-name tname)))
-	 (%test-comp2body r comp expected expr)))
-      ((%test-comp2 comp expected expr)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp2body r comp expected expr)))))
-  (define-syntax test-equal
-    (syntax-rules ()
-      ((test-equal . rest)
-       (%test-comp2 equal? . rest))))
-  (define-syntax test-eqv
-    (syntax-rules ()
-      ((test-eqv . rest)
-       (%test-comp2 eqv? . rest))))
-  (define-syntax test-eq
-    (syntax-rules ()
-      ((test-eq . rest)
-       (%test-comp2 eq? . rest))))
-  (define-syntax test-approximate
-    (syntax-rules ()
-      ((test-approximate tname expected expr error)
-       (%test-comp2 (%test-approximate= error) tname expected expr))
-      ((test-approximate expected expr error)
-       (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (cond ((%test-on-test-begin r)
-              (let ((et etype))
-                (test-result-set! r 'expected-error et)
-                (%test-on-test-end r
-                                   (catch #t
-                                     (lambda ()
-                                       (test-result-set! r 'actual-value expr)
-                                       #f)
-                                     (lambda (key . args)
-                                       ;; TODO: decide how to specify expected
-                                       ;; error types for Guile.
-                                       (test-result-set! r 'actual-error
-                                                         (cons key args))
-                                       #t)))
-                (%test-report-result))))))))
- (mzscheme
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
-					 (let ()
-					   (test-result-set! r 'actual-value expr)
-					   #f)))))))
- (chicken
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-        (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r #t expr)
-       (cond ((%test-on-test-begin r)
-	      (test-result-set! r 'expected-error #t)
-	      (%test-on-test-end r
-				 (try-catch
-				  (let ()
-				    (test-result-set! r 'actual-value expr)
-				    #f)
-				  (ex <java.lang.Throwable>
-				      (test-result-set! r 'actual-error ex)
-				      #t)))
-	      (%test-report-result))))
-      ((%test-error r etype expr)
-       (if (%test-on-test-begin r)
-	   (let ((et etype))
-	     (test-result-set! r 'expected-error et)
-	     (%test-on-test-end r
-				(try-catch
-				 (let ()
-				   (test-result-set! r 'actual-value expr)
-				   #f)
-				 (ex <java.lang.Throwable>
-				     (test-result-set! r 'actual-error ex)
-				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
-						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
-					    (instance? ex et))
-					   (else #t)))))
-	     (%test-report-result)))))))
- ((and srfi-34 srfi-35)
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex ((condition-type? etype)
-		   (and (condition? ex) (condition-has-type? ex etype)))
-		  ((procedure? etype)
-		   (etype ex))
-		  ((equal? etype #t)
-		   #t)
-		  (else #t))
-	      expr #f))))))
- (srfi-34
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (begin
-	 ((test-runner-on-test-begin r) r)
-	 (test-result-set! r 'result-kind 'skip)
-	 (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
-  (define-syntax test-error
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-error r etype expr))))
-	(((mac etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r etype expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r #t expr))))))))
- (else
-  (define-syntax test-error
-    (syntax-rules ()
-      ((test-error name etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r `((test-name . ,name)))
-         (%test-error r etype expr)))
-      ((test-error etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r etype expr)))
-      ((test-error expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
-  (if (test-runner? first)
-      (test-with-runner first (apply test-apply rest))
-      (let ((r (test-runner-current)))
-	(if r
-	    (let ((run-list (%test-runner-run-list r)))
-	      (cond ((null? rest)
-		     (%test-runner-run-list! r (reverse run-list))
-		     (first)) ;; actually apply procedure thunk
-		    (else
-		     (%test-runner-run-list!
-		      r
-		      (if (eq? run-list #t) (list first) (cons first run-list)))
-		     (apply test-apply rest)
-		     (%test-runner-run-list! r run-list))))
-	    (let ((r (test-runner-create)))
-	      (test-with-runner r (apply test-apply first rest))
-	      ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
-  (syntax-rules ()
-    ((test-with-runner runner form ...)
-     (let ((saved-runner (test-runner-current)))
-       (dynamic-wind
-           (lambda () (test-runner-current runner))
-           (lambda () form ...)
-           (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
-  (let ((i 0))
-    (lambda (runner)
-      (set! i (+ i 1))
-      (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
-  (syntax-rules ()
-    ((test-match-nth n)
-     (test-match-nth n 1))
-    ((test-match-nth n count)
-     (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
-  (lambda (runner)
-    (let ((result #t))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if (not ((car l) runner))
-		  (set! result #f))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-all
-  (syntax-rules ()
-    ((test-match-all pred ...)
-     (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
-  (lambda (runner)
-    (let ((result #f))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if ((car l) runner)
-		  (set! result #t))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-any
-  (syntax-rules ()
-    ((test-match-any pred ...)
-     (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
-  (cond ((procedure? specifier) specifier)
-	((integer? specifier) (test-match-nth 1 specifier))
-	((string? specifier) (test-match-name specifier))
-	(else
-	 (error "not a valid test specifier"))))
-
-(define-syntax test-skip
-  (syntax-rules ()
-    ((test-skip pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-skip-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
-  (syntax-rules ()
-    ((test-expect-fail pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-fail-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
-  (lambda (runner)
-    (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
-  (let* ((port (open-input-string string))
-	 (form (read port)))
-    (if (eof-object? (read-char port))
-	(cond-expand
-	 (guile (eval form (current-module)))
-	 (else (eval form)))
-	(cond-expand
-	 (srfi-23 (error "(not at eof)"))
-	 (else "error")))))
-
-- 
2.30.2


[-- Attachment #3: 0002-Augment-SRFI-64-test-suite.patch --]
[-- Type: text/plain, Size: 1901 bytes --]

From 79376c91335e39898962640e27a3c4c6b1098576 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:26:10 +0200
Subject: [PATCH 2/2] Augment SRFI-64 test-suite.

* test-suite/tests/srfi-64-test.scm ("1.3. test-approximate"): New
  section.
("2.1.4. FAIL with a test name and error type"):
("2.1.5. PASS with an error type but no name"):
("2.1.6. FAIL with an error type but no name"): New tests.
---
 test-suite/tests/srfi-64-test.scm | 37 +++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..b7f6d2934 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -167,6 +167,19 @@
 
 (test-end);1.2
 
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-approximate "a" (mean 3 5) 4   0.001)
+    (test-approximate "b" (mean 3 5) 4.5 0.001)
+    (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
 (test-end "1. Simple test-cases")
 
 ;;;
@@ -202,6 +215,30 @@
     ;; PASS
     (test-error "a" #t (vector-ref '#(1 2) 9)))))
 
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error #t (vector-ref '#(1 2) 0)))))
+
 (test-end "2.1. test-error")
 
 (test-end "2. Tests for catching errors")
-- 
2.30.2


^ permalink raw reply related	[flat|nested] 6+ messages in thread

* Re: [PATCHES] Use a better SRFI-64 implementation.
  2021-05-10 18:25 [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
  2021-05-11 11:32 ` Taylan Kammer
  2021-05-11 14:32 ` Taylan Kammer
@ 2021-05-11 19:39 ` Taylan Kammer
  2 siblings, 0 replies; 6+ messages in thread
From: Taylan Kammer @ 2021-05-11 19:39 UTC (permalink / raw)
  To: guile-devel

I was just skimming through the bug tracker and noticed:

    https://bugs.gnu.org/21181

This bug doesn't exist in the proposed implementation.


- Taylan



^ permalink raw reply	[flat|nested] 6+ messages in thread

* Re: [PATCHES] Use a better SRFI-64 implementation.
  2021-05-11 19:14   ` Taylan Kammer
@ 2021-05-11 20:52     ` Taylan Kammer
  0 siblings, 0 replies; 6+ messages in thread
From: Taylan Kammer @ 2021-05-11 20:52 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 620 bytes --]

On 11.05.2021 21:14, Taylan Kammer wrote:
> 
> And here's another minimally changed one.
> 

Aaaand another of course.  <lampilelo> on IRC notified me that
there's a way in which both the old and new implementation don't
conform to the standard: they're supposed to uninstall the default
test runner that they install automatically, after tests ended.

I'm not sure if there's any real benefit to actually doing that,
but I've followed <lampilelo>'s suggestion and implemented it.

So here's yet another updated patch-set!  You won't be getting
another one for at least 8 hours as I'm going to sleep now. ;-)


- Taylan

[-- Attachment #2: 0001-Use-a-different-SRFI-64-implementation.patch --]
[-- Type: text/plain, Size: 76388 bytes --]

From 6746edaf52066c147d85548f439a37beb0c0344c Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:23:17 +0200
Subject: [PATCH 1/2] Use a different 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                       |   17 +-
 module/srfi/srfi-64/execution.body.scm        |  431 +++++++
 module/srfi/srfi-64/source-info.body.scm      |   88 ++
 .../srfi/srfi-64/test-runner-simple.body.scm  |  173 +++
 module/srfi/srfi-64/test-runner.body.scm      |  168 +++
 module/srfi/srfi-64/testing.scm               | 1044 -----------------
 7 files changed, 882 insertions(+), 1050 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 41b77095b..e1c5267e7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
 ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
-srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+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
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
 
 # Keep this rule in sync with that in `am/guilec'.
@@ -403,7 +407,10 @@ NOCOMP_SOURCES =				\
   ice-9/r7rs-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 925726f5c..e6c6ce80a 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
@@ -48,9 +48,18 @@
    test-on-group-begin-simple test-on-group-end-simple
    test-on-bad-count-simple test-on-bad-end-name-simple
    test-on-final-simple test-on-test-end-simple
-   test-on-final-simple)
-  #:declarative? #f) ; #f needed for test-log-to-file
+   test-on-final-simple))
 
 (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 000000000..276b16653
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,431 @@
+;; 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 ((log-file (string-append suite-name ".srfi64.log"))
+          (runner (test-runner-simple log-file)))
+      (%test-runner-auto-installed! runner #t)
+      (test-runner-current runner))))
+
+(define (maybe-uninstall-default-runner)
+  (when (%test-runner-auto-installed? (test-runner-current))
+    (test-runner-current #f)))
+
+(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)
+           (maybe-uninstall-default-runner)))))))
+
+(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 000000000..684873587
--- /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 000000000..870b314dc
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner-simple.body.scm
@@ -0,0 +1,173 @@
+;; 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
+  (case-lambda
+   (()
+    (test-runner-simple #f))
+   ((log-file)
+    (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)
+      (%test-runner-log-file!          runner log-file)
+      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 000000000..bde7e502e
--- /dev/null
+++ b/module/srfi/srfi-64/test-runner.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.
+
+\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!)
+
+  (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!)
+
+  (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-auto-installed! runner #f)
+    (%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 cdaab140f..000000000
--- a/module/srfi/srfi-64/testing.scm
+++ /dev/null
@@ -1,1044 +0,0 @@
-;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
-;; Added "full" support for Chicken, Gauche, Guile and SISC.
-;;   Alex Shinn, Copyright (c) 2005.
-;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
-;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
-;;
-;; Permission is hereby granted, free of charge, to any person
-;; obtaining a copy of this software and associated documentation
-;; files (the "Software"), to deal in the Software without
-;; restriction, including without limitation the rights to use, copy,
-;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;; of the Software, and to permit persons to whom the Software is
-;; furnished to do so, subject to the following conditions:
-;;
-;; The above copyright notice and this permission notice shall be
-;; included in all copies or substantial portions of the Software.
-;;
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-;; SOFTWARE.
-
-(cond-expand
- (chicken
-  (require-extension syntax-case))
- (guile-2
-  (use-modules (srfi srfi-9)
-               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
-               ;; with either Guile's native exceptions or R6RS exceptions.
-               ;;(srfi srfi-34) (srfi srfi-35)
-               (srfi srfi-39)))
- (guile
-  (use-modules (ice-9 syncase) (srfi srfi-9)
-	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
-	       (srfi srfi-39)))
- (sisc
-  (require-extension (srfi 9 34 35 39)))
- (kawa
-  (module-compile-options warn-undefined-variable: #t
-			  warn-invoke-unknown-method: #t)
-  (provide 'srfi-64)
-  (provide 'testing)
-  (require 'srfi-34)
-  (require 'srfi-35))
- (else ()
-  ))
-
-(cond-expand
- (kawa
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export test-begin . other-names)
-       (module-export %test-begin . other-names)))))
- (else
-  (define-syntax %test-export
-    (syntax-rules ()
-      ((%test-export . names) (if #f #f))))))
-
-;; List of exported names
-(%test-export
- test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
- test-end test-assert test-eqv test-eq test-equal
- test-approximate test-assert test-error test-apply test-with-runner
- test-match-nth test-match-all test-match-any test-match-name
- test-skip test-expect-fail test-read-eval-string
- test-runner-group-path test-group test-group-with-cleanup
- test-result-ref test-result-set! test-result-clear test-result-remove
- test-result-kind test-passed?
- test-log-to-file
- ; Misc test-runner functions
- test-runner? test-runner-reset test-runner-null
- test-runner-simple test-runner-current test-runner-factory test-runner-get
- test-runner-create test-runner-test-name
- ;; test-runner field setter and getter functions - see %test-record-define:
- test-runner-pass-count test-runner-pass-count!
- test-runner-fail-count test-runner-fail-count!
- test-runner-xpass-count test-runner-xpass-count!
- test-runner-xfail-count test-runner-xfail-count!
- test-runner-skip-count test-runner-skip-count!
- test-runner-group-stack test-runner-group-stack!
- test-runner-on-test-begin test-runner-on-test-begin!
- test-runner-on-test-end test-runner-on-test-end!
- test-runner-on-group-begin test-runner-on-group-begin!
- test-runner-on-group-end test-runner-on-group-end!
- test-runner-on-final test-runner-on-final!
- test-runner-on-bad-count test-runner-on-bad-count!
- test-runner-on-bad-end-name test-runner-on-bad-end-name!
- test-result-alist test-result-alist!
- test-runner-aux-value test-runner-aux-value!
- ;; default/simple call-back functions, used in default test-runner,
- ;; but can be called to construct more complex ones.
- test-on-group-begin-simple test-on-group-end-simple
- test-on-bad-count-simple test-on-bad-end-name-simple
- test-on-final-simple test-on-test-end-simple
- test-on-final-simple)
-
-(cond-expand
- (srfi-9
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index setter getter) ...)
-       (define-record-type test-runner
-	 (alloc)
-	 runner?
-	 (name setter getter) ...)))))
- (else
-  (define %test-runner-cookie (list "test-runner"))
-  (define-syntax %test-record-define
-    (syntax-rules ()
-      ((%test-record-define alloc runner? (name index getter setter) ...)
-       (begin
-	 (define (runner? obj)
-	   (and (vector? obj)
-		(> (vector-length obj) 1)
-		(eq (vector-ref obj 0) %test-runner-cookie)))
-	 (define (alloc)
-	   (let ((runner (make-vector 23)))
-	     (vector-set! runner 0 %test-runner-cookie)
-	     runner))
-	 (begin
-	   (define (getter runner)
-	     (vector-ref runner index)) ...)
-	 (begin
-	   (define (setter runner value)
-	     (vector-set! runner index value)) ...)))))))
-
-(%test-record-define
- %test-runner-alloc test-runner?
- ;; Cumulate count of all tests that have passed and were expected to.
- (pass-count 1 test-runner-pass-count test-runner-pass-count!)
- (fail-count 2 test-runner-fail-count test-runner-fail-count!)
- (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
- (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
- (skip-count 5 test-runner-skip-count test-runner-skip-count!)
- (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
- (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
- ;; Normally #t, except when in a test-apply.
- (run-list 8 %test-runner-run-list %test-runner-run-list!)
- (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
- (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
- (group-stack 11 test-runner-group-stack test-runner-group-stack!)
- (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
- (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
- ;; Call-back when entering a group. Takes (runner suite-name count).
- (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
- ;; Call-back when leaving a group.
- (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
- ;; Call-back when leaving the outermost group.
- (on-final 16 test-runner-on-final test-runner-on-final!)
- ;; Call-back when expected number of tests was wrong.
- (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
- ;; Call-back when name in test=end doesn't match test-begin.
- (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
- ;; Cumulate count of all tests that have been done.
- (total-count 19 %test-runner-total-count %test-runner-total-count!)
- ;; Stack (list) of (count-at-start . expected-count):
- (count-list 20 %test-runner-count-list %test-runner-count-list!)
- (result-alist 21 test-result-alist test-result-alist!)
- ;; Field can be used by test-runner for any purpose.
- ;; test-runner-simple uses it for a log file.
- (aux-value 22 test-runner-aux-value test-runner-aux-value!)
-)
-
-(define (test-runner-reset runner)
-  (test-result-alist! runner '())
-  (test-runner-pass-count! runner 0)
-  (test-runner-fail-count! runner 0)
-  (test-runner-xpass-count! runner 0)
-  (test-runner-xfail-count! runner 0)
-  (test-runner-skip-count! runner 0)
-  (%test-runner-total-count! runner 0)
-  (%test-runner-count-list! runner '())
-  (%test-runner-run-list! runner #t)
-  (%test-runner-skip-list! runner '())
-  (%test-runner-fail-list! runner '())
-  (%test-runner-skip-save! runner '())
-  (%test-runner-fail-save! runner '())
-  (test-runner-group-stack! runner '()))
-
-(define (test-runner-group-path runner)
-  (reverse (test-runner-group-stack runner)))
-
-(define (%test-null-callback runner) #f)
-
-(define (test-runner-null)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
-    (test-runner-on-group-end! runner %test-null-callback)
-    (test-runner-on-final! runner %test-null-callback)
-    (test-runner-on-test-begin! runner %test-null-callback)
-    (test-runner-on-test-end! runner %test-null-callback)
-    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
-    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
-    runner))
-
-;; Not part of the specification.  FIXME
-;; Controls whether a log file is generated.
-(define test-log-to-file #t)
-
-(define (test-runner-simple)
-  (let ((runner (%test-runner-alloc)))
-    (test-runner-reset runner)
-    (test-runner-on-group-begin! runner test-on-group-begin-simple)
-    (test-runner-on-group-end! runner test-on-group-end-simple)
-    (test-runner-on-final! runner test-on-final-simple)
-    (test-runner-on-test-begin! runner test-on-test-begin-simple)
-    (test-runner-on-test-end! runner test-on-test-end-simple)
-    (test-runner-on-bad-count! runner test-on-bad-count-simple)
-    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
-    runner))
-
-(cond-expand
- (srfi-39
-  (define test-runner-current (make-parameter #f))
-  (define test-runner-factory (make-parameter test-runner-simple)))
- (else
-  (define %test-runner-current #f)
-  (define-syntax test-runner-current
-    (syntax-rules ()
-      ((test-runner-current)
-       %test-runner-current)
-      ((test-runner-current runner)
-       (set! %test-runner-current runner))))
-  (define %test-runner-factory test-runner-simple)
-  (define-syntax test-runner-factory
-    (syntax-rules ()
-      ((test-runner-factory)
-       %test-runner-factory)
-      ((test-runner-factory runner)
-       (set! %test-runner-factory runner))))))
-
-;; A safer wrapper to test-runner-current.
-(define (test-runner-get)
-  (let ((r (test-runner-current)))
-    (if (not r)
-	(cond-expand
-	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
-	 (else #t)))
-    r))
-
-(define (%test-specifier-matches spec runner)
-  (spec runner))
-
-(define (test-runner-create)
-  ((test-runner-factory)))
-
-(define (%test-any-specifier-matches list runner)
-  (let ((result #f))
-    (let loop ((l list))
-      (cond ((null? l) result)
-	    (else
-	     (if (%test-specifier-matches (car l) runner)
-		 (set! result #t))
-	     (loop (cdr l)))))))
-
-;; Returns #f, #t, or 'xfail.
-(define (%test-should-execute runner)
-  (let ((run (%test-runner-run-list runner)))
-    (cond ((or
-	    (not (or (eqv? run #t)
-		     (%test-any-specifier-matches run runner)))
-	    (%test-any-specifier-matches
-	     (%test-runner-skip-list runner)
-	     runner))
-	    (test-result-set! runner 'result-kind 'skip)
-	    #f)
-	  ((%test-any-specifier-matches
-	    (%test-runner-fail-list runner)
-	    runner)
-	   (test-result-set! runner 'result-kind 'xfail)
-	   'xfail)
-	  (else #t))))
-
-(define (%test-begin suite-name count)
-  (if (not (test-runner-current))
-      (let ((r (test-runner-create)))
-	(test-runner-current r)
-	(test-runner-on-final! r
-	  (let ((old-final (test-runner-on-final r)))
-	    (lambda (r) (old-final r) (test-runner-current #f))))))
-  (let ((runner (test-runner-current)))
-    ((test-runner-on-group-begin runner) runner suite-name count)
-    (%test-runner-skip-save! runner
-			       (cons (%test-runner-skip-list runner)
-				     (%test-runner-skip-save runner)))
-    (%test-runner-fail-save! runner
-			       (cons (%test-runner-fail-list runner)
-				     (%test-runner-fail-save runner)))
-    (%test-runner-count-list! runner
-			     (cons (cons (%test-runner-total-count runner)
-					 count)
-				   (%test-runner-count-list runner)))
-    (test-runner-group-stack! runner (cons suite-name
-					(test-runner-group-stack runner)))))
-(cond-expand
- (kawa
-  ;; Kawa has test-begin built in, implemented as:
-  ;; (begin
-  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
-  ;;   (%test-begin suite-name [count]))
-  ;; This puts test-begin but only test-begin in the default environment.,
-  ;; which makes normal test suites loadable without non-portable commands.
-  )
- (else
-  (define-syntax test-begin
-    (syntax-rules ()
-      ((test-begin suite-name)
-       (%test-begin suite-name #f))
-      ((test-begin suite-name count)
-       (%test-begin suite-name count))))))
-
-(define (test-on-group-begin-simple runner suite-name count)
-  (if (null? (test-runner-group-stack runner))
-      (begin
-	(display "%%%% Starting test ")
-	(display suite-name)
-	(if test-log-to-file
-	    (let* ((log-file-name
-		    (if (string? test-log-to-file) test-log-to-file
-			(string-append suite-name ".log")))
-		   (log-file
-		    (cond-expand (mzscheme
-				  (open-output-file log-file-name 'truncate/replace))
-				 (else (open-output-file log-file-name)))))
-	      (display "%%%% Starting test " log-file)
-	      (display suite-name log-file)
-	      (newline log-file)
-	      (test-runner-aux-value! runner log-file)
-	      (display "  (Writing full log to \"")
-	      (display log-file-name)
-	      (display "\")")))
-	(newline)))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group begin: " log)
-	  (display suite-name log)
-	  (newline log))))
-  #f)
-
-(define (test-on-group-end-simple runner)
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(begin
-	  (display "Group end: " log)
-	  (display (car (test-runner-group-stack runner)) log)
-	  (newline log))))
-  #f)
-
-(define (%test-on-bad-count-write runner count expected-count port)
-  (display "*** Total number of tests was " port)
-  (display count port)
-  (display " but should be " port)
-  (display expected-count port)
-  (display ". ***" port)
-  (newline port)
-  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
-  (newline port))
-
-(define (test-on-bad-count-simple runner count expected-count)
-  (%test-on-bad-count-write runner count expected-count (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-on-bad-count-write runner count expected-count log))))
-
-(define (test-on-bad-end-name-simple runner begin-name end-name)
-  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
-			    " does not match test-begin " end-name)))
-    (cond-expand
-     (srfi-23 (error msg))
-     (else (display msg) (newline)))))
-  
-
-(define (%test-final-report1 value label port)
-  (if (> value 0)
-      (begin
-	(display label port)
-	(display value port)
-	(newline port))))
-
-(define (%test-final-report-simple runner port)
-  (%test-final-report1 (test-runner-pass-count runner)
-		      "# of expected passes      " port)
-  (%test-final-report1 (test-runner-xfail-count runner)
-		      "# of expected failures    " port)
-  (%test-final-report1 (test-runner-xpass-count runner)
-		      "# of unexpected successes " port)
-  (%test-final-report1 (test-runner-fail-count runner)
-		      "# of unexpected failures  " port)
-  (%test-final-report1 (test-runner-skip-count runner)
-		      "# of skipped tests        " port))
-
-(define (test-on-final-simple runner)
-  (%test-final-report-simple runner (current-output-port))
-  (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(%test-final-report-simple runner log))))
-
-(define (%test-format-line runner)
-   (let* ((line-info (test-result-alist runner))
-	  (source-file (assq 'source-file line-info))
-	  (source-line (assq 'source-line line-info))
-	  (file (if source-file (cdr source-file) "")))
-     (if source-line
-	 (string-append file ":"
-			(number->string (cdr source-line)) ": ")
-	 "")))
-
-(define (%test-end suite-name line-info)
-  (let* ((r (test-runner-get))
-	 (groups (test-runner-group-stack r))
-	 (line (%test-format-line r)))
-    (test-result-alist! r line-info)
-    (if (null? groups)
-	(let ((msg (string-append line "test-end not in a group")))
-	  (cond-expand
-	   (srfi-23 (error msg))
-	   (else (display msg) (newline)))))
-    (if (and suite-name (not (equal? suite-name (car groups))))
-	((test-runner-on-bad-end-name r) r suite-name (car groups)))
-    (let* ((count-list (%test-runner-count-list r))
-	   (expected-count (cdar count-list))
-	   (saved-count (caar count-list))
-	   (group-count (- (%test-runner-total-count r) saved-count)))
-      (if (and expected-count
-	       (not (= expected-count group-count)))
-	  ((test-runner-on-bad-count r) r group-count expected-count))
-      ((test-runner-on-group-end r) r)
-      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
-      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
-      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
-      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
-      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
-      (%test-runner-count-list! r (cdr count-list))
-      (if (null? (test-runner-group-stack r))
-	  ((test-runner-on-final r) r)))))
-
-(define-syntax test-group
-  (syntax-rules ()
-    ((test-group suite-name . body)
-     (let ((r (test-runner-current)))
-       ;; Ideally should also set line-number, if available.
-       (test-result-alist! r (list (cons 'test-name suite-name)))
-       (if (%test-should-execute r)
-	   (dynamic-wind
-	       (lambda () (test-begin suite-name))
-	       (lambda () . body)
-	       (lambda () (test-end  suite-name))))))))
-
-(define-syntax test-group-with-cleanup
-  (syntax-rules ()
-    ((test-group-with-cleanup suite-name form cleanup-form)
-     (test-group suite-name
-		    (dynamic-wind
-			(lambda () #f)
-			(lambda () form)
-			(lambda () cleanup-form))))
-    ((test-group-with-cleanup suite-name cleanup-form)
-     (test-group-with-cleanup suite-name #f cleanup-form))
-    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
-     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
-
-(define (test-on-test-begin-simple runner)
- (let ((log (test-runner-aux-value runner)))
-    (if (output-port? log)
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (source-form (assq 'source-form results))
-	       (test-name (assq 'test-name results)))
-	  (display "Test begin:" log)
-	  (newline log)
-	  (if test-name (%test-write-result1 test-name log))
-	  (if source-file (%test-write-result1 source-file log))
-	  (if source-line (%test-write-result1 source-line log))
-	  (if source-form (%test-write-result1 source-form log))))))
-
-(define-syntax test-result-ref
-  (syntax-rules ()
-    ((test-result-ref runner pname)
-     (test-result-ref runner pname #f))
-    ((test-result-ref runner pname default)
-     (let ((p (assq pname (test-result-alist runner))))
-       (if p (cdr p) default)))))
-
-(define (test-on-test-end-simple runner)
-  (let ((log (test-runner-aux-value runner))
-	(kind (test-result-ref runner 'result-kind)))
-    (if (memq kind '(fail xpass))
-	(let* ((results (test-result-alist runner))
-	       (source-file (assq 'source-file results))
-	       (source-line (assq 'source-line results))
-	       (test-name (assq 'test-name results)))
-	  (if (or source-file source-line)
-	      (begin
-		(if source-file (display (cdr source-file)))
-		(display ":")
-		(if source-line (display (cdr source-line)))
-		(display ": ")))
-	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
-	  (if test-name
-	      (begin
-		(display " ")
-		(display (cdr test-name))))
-	  (newline)))
-    (if (output-port? log)
-	(begin
-	  (display "Test end:" log)
-	  (newline log)
-	  (let loop ((list (test-result-alist runner)))
-	    (if (pair? list)
-		(let ((pair (car list)))
-		  ;; Write out properties not written out by on-test-begin.
-		  (if (not (memq (car pair)
-				 '(test-name source-file source-line source-form)))
-		      (%test-write-result1 pair log))
-		  (loop (cdr list)))))))))
-
-(define (%test-write-result1 pair port)
-  (display "  " port)
-  (display (car pair) port)
-  (display ": " port)
-  (write (cdr pair) port)
-  (newline port))
-
-(define (test-result-set! runner pname value)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(set-cdr! p value)
-	(test-result-alist! runner (cons (cons pname value) alist)))))
-
-(define (test-result-clear runner)
-  (test-result-alist! runner '()))
-
-(define (test-result-remove runner pname)
-  (let* ((alist (test-result-alist runner))
-	 (p (assq pname alist)))
-    (if p
-	(test-result-alist! runner
-				   (let loop ((r alist))
-				     (if (eq? r p) (cdr r)
-					 (cons (car r) (loop (cdr r)))))))))
-
-(define (test-result-kind . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
-    (test-result-ref runner 'result-kind)))
-
-(define (test-passed? . rest)
-  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
-    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
-
-(define (%test-report-result)
-  (let* ((r (test-runner-get))
-	 (result-kind (test-result-kind r)))
-    (case result-kind
-      ((pass)
-       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
-      ((fail)
-       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
-      ((xpass)
-       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
-      ((xfail)
-       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
-      (else
-       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
-    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
-    ((test-runner-on-test-end r) r)))
-
-(cond-expand
- (guile
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (catch #t
-         (lambda () test-expression)
-         (lambda (key . args)
-           (test-result-set! (test-runner-current) 'actual-error
-                             (cons key args))
-           #f))))))
- (kawa
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (try-catch test-expression
-		  (ex <java.lang.Throwable>
-		      (test-result-set! (test-runner-current) 'actual-error ex)
-		      #f))))))
- (srfi-34
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (guard (err (else #f)) test-expression)))))
- (chicken
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       (condition-case test-expression (ex () #f))))))
- (else
-  (define-syntax %test-evaluate-with-catch
-    (syntax-rules ()
-      ((%test-evaluate-with-catch test-expression)
-       test-expression)))))
-	    
-(cond-expand
- ((or kawa mzscheme)
-  (cond-expand
-   (mzscheme
-    (define-for-syntax (%test-syntax-file form)
-      (let ((source (syntax-source form)))
-	(cond ((string? source) file)
-				((path? source) (path->string source))
-				(else #f)))))
-   (kawa
-    (define (%test-syntax-file form)
-      (syntax-source form))))
-  (define (%test-source-line2 form)
-    (let* ((line (syntax-line form))
-	   (file (%test-syntax-file form))
-	   (line-pair (if line (list (cons 'source-line line)) '())))
-      (cons (cons 'source-form (syntax-object->datum form))
-	    (if file (cons (cons 'source-file file) line-pair) line-pair)))))
- (guile-2
-  (define (%test-source-line2 form)
-    (let* ((src-props (syntax-source form))
-           (file (and src-props (assq-ref src-props 'filename)))
-           (line (and src-props (assq-ref src-props 'line)))
-           (file-alist (if file
-                           `((source-file . ,file))
-                           '()))
-           (line-alist (if line
-                           `((source-line . ,(+ line 1)))
-                           '())))
-      (datum->syntax (syntax here)
-                     `((source-form . ,(syntax->datum form))
-                       ,@file-alist
-                       ,@line-alist)))))
- (else
-  (define (%test-source-line2 form)
-    '())))
-
-(define (%test-on-test-begin r)
-  (%test-should-execute r)
-  ((test-runner-on-test-begin r) r)
-  (not (eq? 'skip (test-result-ref r 'result-kind))))
-
-(define (%test-on-test-end r result)
-    (test-result-set! r 'result-kind
-		      (if (eq? (test-result-ref r 'result-kind) 'xfail)
-			  (if result 'xpass 'xfail)
-			  (if result 'pass 'fail))))
-
-(define (test-runner-test-name runner)
-  (test-result-ref runner 'test-name ""))
-
-(define-syntax %test-comp2body
-  (syntax-rules ()
-		((%test-comp2body r comp expected expr)
-		 (let ()
-		   (if (%test-on-test-begin r)
-		       (let ((exp expected))
-			 (test-result-set! r 'expected-value exp)
-			 (let ((res (%test-evaluate-with-catch expr)))
-			   (test-result-set! r 'actual-value res)
-			   (%test-on-test-end r (comp exp res)))))
-		   (%test-report-result)))))
-
-(define (%test-approximate= error)
-  (lambda (value expected)
-    (let ((rval (real-part value))
-          (ival (imag-part value))
-          (rexp (real-part expected))
-          (iexp (imag-part expected)))
-      (and (>= rval (- rexp error))
-           (>= ival (- iexp error))
-           (<= rval (+ rexp error))
-           (<= ival (+ iexp error))))))
-
-(define-syntax %test-comp1body
-  (syntax-rules ()
-    ((%test-comp1body r expr)
-     (let ()
-       (if (%test-on-test-begin r)
-	   (let ()
-	     (let ((res (%test-evaluate-with-catch expr)))
-	       (test-result-set! r 'actual-value res)
-	       (%test-on-test-end r res))))
-       (%test-report-result)))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-  ;; Should be made to work for any Scheme with syntax-case
-  ;; However, I haven't gotten the quoting working.  FIXME.
-  (define-syntax test-end
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac suite-name) line)
-	 (syntax
-	  (%test-end suite-name line)))
-	(((mac) line)
-	 (syntax
-	  (%test-end #f line))))))
-  (define-syntax test-assert
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-comp1body r expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-comp1body r expr)))))))
-  (define (%test-comp2 comp x)
-    (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) ()
-      (((mac tname expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r comp expected expr))))
-      (((mac expected expr) line comp)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r comp expected expr))))))
-  (define-syntax test-eqv
-    (lambda (x) (%test-comp2 (syntax eqv?) x)))
-  (define-syntax test-eq
-    (lambda (x) (%test-comp2 (syntax eq?) x)))
-  (define-syntax test-equal
-    (lambda (x) (%test-comp2 (syntax equal?) x)))
-  (define-syntax test-approximate ;; FIXME - needed for non-Kawa
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-      (((mac tname expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get))
-	       (name tname))
-	  (test-result-alist! r (cons (cons 'test-name tname) line))
-	  (%test-comp2body r (%test-approximate= error) expected expr))))
-      (((mac expected expr error) line)
-       (syntax
-	(let* ((r (test-runner-get)))
-	  (test-result-alist! r line)
-	  (%test-comp2body r (%test-approximate= error) expected expr))))))))
- (else
-  (define-syntax test-end
-    (syntax-rules ()
-      ((test-end)
-       (%test-end #f '()))
-      ((test-end suite-name)
-       (%test-end suite-name '()))))
-  (define-syntax test-assert
-    (syntax-rules ()
-      ((test-assert tname test-expression)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r '((test-name . tname)))
-	 (%test-comp1body r test-expression)))
-      ((test-assert test-expression)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp1body r test-expression)))))
-  (define-syntax %test-comp2
-    (syntax-rules ()
-      ((%test-comp2 comp tname expected expr)
-       (let* ((r (test-runner-get))
-	      (name tname))
-	 (test-result-alist! r (list (cons 'test-name tname)))
-	 (%test-comp2body r comp expected expr)))
-      ((%test-comp2 comp expected expr)
-       (let* ((r (test-runner-get)))
-	 (test-result-alist! r '())
-	 (%test-comp2body r comp expected expr)))))
-  (define-syntax test-equal
-    (syntax-rules ()
-      ((test-equal . rest)
-       (%test-comp2 equal? . rest))))
-  (define-syntax test-eqv
-    (syntax-rules ()
-      ((test-eqv . rest)
-       (%test-comp2 eqv? . rest))))
-  (define-syntax test-eq
-    (syntax-rules ()
-      ((test-eq . rest)
-       (%test-comp2 eq? . rest))))
-  (define-syntax test-approximate
-    (syntax-rules ()
-      ((test-approximate tname expected expr error)
-       (%test-comp2 (%test-approximate= error) tname expected expr))
-      ((test-approximate expected expr error)
-       (%test-comp2 (%test-approximate= error) expected expr))))))
-
-(cond-expand
- (guile
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (cond ((%test-on-test-begin r)
-              (let ((et etype))
-                (test-result-set! r 'expected-error et)
-                (%test-on-test-end r
-                                   (catch #t
-                                     (lambda ()
-                                       (test-result-set! r 'actual-value expr)
-                                       #f)
-                                     (lambda (key . args)
-                                       ;; TODO: decide how to specify expected
-                                       ;; error types for Guile.
-                                       (test-result-set! r 'actual-error
-                                                         (cons key args))
-                                       #t)))
-                (%test-report-result))))))))
- (mzscheme
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t)))
-					 (let ()
-					   (test-result-set! r 'actual-value expr)
-					   #f)))))))
- (chicken
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-        (%test-comp1body r (condition-case expr (ex () #t)))))))
- (kawa
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r #t expr)
-       (cond ((%test-on-test-begin r)
-	      (test-result-set! r 'expected-error #t)
-	      (%test-on-test-end r
-				 (try-catch
-				  (let ()
-				    (test-result-set! r 'actual-value expr)
-				    #f)
-				  (ex <java.lang.Throwable>
-				      (test-result-set! r 'actual-error ex)
-				      #t)))
-	      (%test-report-result))))
-      ((%test-error r etype expr)
-       (if (%test-on-test-begin r)
-	   (let ((et etype))
-	     (test-result-set! r 'expected-error et)
-	     (%test-on-test-end r
-				(try-catch
-				 (let ()
-				   (test-result-set! r 'actual-value expr)
-				   #f)
-				 (ex <java.lang.Throwable>
-				     (test-result-set! r 'actual-error ex)
-				     (cond ((and (instance? et <gnu.bytecode.ClassType>)
-						 (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
-					    (instance? ex et))
-					   (else #t)))))
-	     (%test-report-result)))))))
- ((and srfi-34 srfi-35)
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex ((condition-type? etype)
-		   (and (condition? ex) (condition-has-type? ex etype)))
-		  ((procedure? etype)
-		   (etype ex))
-		  ((equal? etype #t)
-		   #t)
-		  (else #t))
-	      expr #f))))))
- (srfi-34
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (%test-comp1body r (guard (ex (else #t)) expr #f))))))
- (else
-  (define-syntax %test-error
-    (syntax-rules ()
-      ((%test-error r etype expr)
-       (begin
-	 ((test-runner-on-test-begin r) r)
-	 (test-result-set! r 'result-kind 'skip)
-	 (%test-report-result)))))))
-
-(cond-expand
- ((or kawa mzscheme guile-2)
-
-  (define-syntax test-error
-    (lambda (x)
-      (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) ()
-	(((mac tname etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get))
-		 (name tname))
-	    (test-result-alist! r (cons (cons 'test-name tname) line))
-	    (%test-error r etype expr))))
-	(((mac etype expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r etype expr))))
-	(((mac expr) line)
-	 (syntax
-	  (let* ((r (test-runner-get)))
-	    (test-result-alist! r line)
-	    (%test-error r #t expr))))))))
- (else
-  (define-syntax test-error
-    (syntax-rules ()
-      ((test-error name etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r `((test-name . ,name)))
-         (%test-error r etype expr)))
-      ((test-error etype expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r etype expr)))
-      ((test-error expr)
-       (let ((r (test-runner-get)))
-         (test-result-alist! r '())
-         (%test-error r #t expr)))))))
-
-(define (test-apply first . rest)
-  (if (test-runner? first)
-      (test-with-runner first (apply test-apply rest))
-      (let ((r (test-runner-current)))
-	(if r
-	    (let ((run-list (%test-runner-run-list r)))
-	      (cond ((null? rest)
-		     (%test-runner-run-list! r (reverse run-list))
-		     (first)) ;; actually apply procedure thunk
-		    (else
-		     (%test-runner-run-list!
-		      r
-		      (if (eq? run-list #t) (list first) (cons first run-list)))
-		     (apply test-apply rest)
-		     (%test-runner-run-list! r run-list))))
-	    (let ((r (test-runner-create)))
-	      (test-with-runner r (apply test-apply first rest))
-	      ((test-runner-on-final r) r))))))
-
-(define-syntax test-with-runner
-  (syntax-rules ()
-    ((test-with-runner runner form ...)
-     (let ((saved-runner (test-runner-current)))
-       (dynamic-wind
-           (lambda () (test-runner-current runner))
-           (lambda () form ...)
-           (lambda () (test-runner-current saved-runner)))))))
-
-;;; Predicates
-
-(define (%test-match-nth n count)
-  (let ((i 0))
-    (lambda (runner)
-      (set! i (+ i 1))
-      (and (>= i n) (< i (+ n count))))))
-
-(define-syntax test-match-nth
-  (syntax-rules ()
-    ((test-match-nth n)
-     (test-match-nth n 1))
-    ((test-match-nth n count)
-     (%test-match-nth n count))))
-
-(define (%test-match-all . pred-list)
-  (lambda (runner)
-    (let ((result #t))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if (not ((car l) runner))
-		  (set! result #f))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-all
-  (syntax-rules ()
-    ((test-match-all pred ...)
-     (%test-match-all (%test-as-specifier pred) ...))))
-
-(define (%test-match-any . pred-list)
-  (lambda (runner)
-    (let ((result #f))
-      (let loop ((l pred-list))
-	(if (null? l)
-	    result
-	    (begin
-	      (if ((car l) runner)
-		  (set! result #t))
-	      (loop (cdr l))))))))
-  
-(define-syntax test-match-any
-  (syntax-rules ()
-    ((test-match-any pred ...)
-     (%test-match-any (%test-as-specifier pred) ...))))
-
-;; Coerce to a predicate function:
-(define (%test-as-specifier specifier)
-  (cond ((procedure? specifier) specifier)
-	((integer? specifier) (test-match-nth 1 specifier))
-	((string? specifier) (test-match-name specifier))
-	(else
-	 (error "not a valid test specifier"))))
-
-(define-syntax test-skip
-  (syntax-rules ()
-    ((test-skip pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-skip-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-skip-list runner)))))))
-
-(define-syntax test-expect-fail
-  (syntax-rules ()
-    ((test-expect-fail pred ...)
-     (let ((runner (test-runner-get)))
-       (%test-runner-fail-list! runner
-				  (cons (test-match-all (%test-as-specifier pred)  ...)
-					(%test-runner-fail-list runner)))))))
-
-(define (test-match-name name)
-  (lambda (runner)
-    (equal? name (test-runner-test-name runner))))
-
-(define (test-read-eval-string string)
-  (let* ((port (open-input-string string))
-	 (form (read port)))
-    (if (eof-object? (read-char port))
-	(cond-expand
-	 (guile (eval form (current-module)))
-	 (else (eval form)))
-	(cond-expand
-	 (srfi-23 (error "(not at eof)"))
-	 (else "error")))))
-
-- 
2.30.2


[-- Attachment #3: 0002-Augment-SRFI-64-test-suite.patch --]
[-- Type: text/plain, Size: 1901 bytes --]

From 846b525be1475815c8e0d25331b17b883717b038 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Mon, 10 May 2021 15:26:10 +0200
Subject: [PATCH 2/2] Augment SRFI-64 test-suite.

* test-suite/tests/srfi-64-test.scm ("1.3. test-approximate"): New
  section.
("2.1.4. FAIL with a test name and error type"):
("2.1.5. PASS with an error type but no name"):
("2.1.6. FAIL with an error type but no name"): New tests.
---
 test-suite/tests/srfi-64-test.scm | 37 +++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
index ca0b58943..b7f6d2934 100644
--- a/test-suite/tests/srfi-64-test.scm
+++ b/test-suite/tests/srfi-64-test.scm
@@ -167,6 +167,19 @@
 
 (test-end);1.2
 
+(test-begin "1.3. test-approximate")
+
+(test-equal
+ "1.3.1. Simple numerical approximation"
+ '(("a" "c") ("b") () () () (2 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-approximate "a" (mean 3 5) 4   0.001)
+    (test-approximate "b" (mean 3 5) 4.5 0.001)
+    (test-approximate "c" (mean 3 5) 4.0 0.001))))
+
+(test-end);1.3
+
 (test-end "1. Simple test-cases")
 
 ;;;
@@ -202,6 +215,30 @@
     ;; PASS
     (test-error "a" #t (vector-ref '#(1 2) 9)))))
 
+(test-equal
+ "2.1.4. FAIL with a test name and error type"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error "a" #t (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.5. PASS with an error type but no name"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error #t (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.6. FAIL with an error type but no name"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL
+    (test-error #t (vector-ref '#(1 2) 0)))))
+
 (test-end "2.1. test-error")
 
 (test-end "2. Tests for catching errors")
-- 
2.30.2


^ permalink raw reply related	[flat|nested] 6+ messages in thread

end of thread, other threads:[~2021-05-11 20:52 UTC | newest]

Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-05-10 18:25 [PATCHES] Use a better SRFI-64 implementation Taylan Kammer
2021-05-11 11:32 ` Taylan Kammer
2021-05-11 19:14   ` Taylan Kammer
2021-05-11 20:52     ` Taylan Kammer
2021-05-11 14:32 ` Taylan Kammer
2021-05-11 19:39 ` Taylan 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).