unofficial mirror of bug-guile@gnu.org 
 help / color / mirror / Atom feed
* bug#48442: [PATCH] Use a better SRFI-64 implementation
@ 2021-05-15 14:16 Taylan Kammer
  0 siblings, 0 replies; only message in thread
From: Taylan Kammer @ 2021-05-15 14:16 UTC (permalink / raw)
  To: 48442

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

Tag: patch


Hi Guilers,

I've posted this to guile-devel already but thought I'd make it a
debbugs ticket to ensure it doesn't get forgotten and because I
made another minor improvement to the implementation. :-)

The first attached patch changes the SRFI-64 implementation shipped
with Guile to the one from the Scheme-SRFIs project.[0]

This implementation has the following advantages:

* Compile times of test suites reduced to less than half. [1]
  This can be quite significant for large test suites.  The one of
  the scheme-bytestructures project is merely a file of less than
  300 tests and yet takes about 9.5s to compile with the old SRFI-64
  implementation on a very modern CPU (Ryzen 9 3900X), and about
  4.5s with the new implementation.  (Using Guile 3.0)

* Modular, clean code using modern Scheme features.  While "clean"
  code may be a subjective thing without concrete, agreed-upon
  criteria, I would implore you to simply take a look at the old
  implementation and compare it to the new one.  I'm confident that
  the new implementation is significantly easier to reason about and
  modify if needed.

* The default test runner outputs results in a format familiar to
  users of GNU software and makes it easier to identify which tests
  failed when they occur in nested test groups.

* The implementation is more conformant to the specification than the
  reference implementation.  In the reference implementation, the
  test runner returned by 'test-runner-simple' uses the 'aux' field
  for a log file, meaning that a user extending the simple test runner
  may not use the aux field.  The spec also says that the runner
  returned by 'test-runner-simple' does no logging.

* Offers a small number of extensions to the standard:
  1. The 'test-runner-simple' procedure takes an optional argument
     that specifies the name of a log file.  (A sane default is chosen
     if the user does not explicitly install any test runner.)  This
     does *not* use the 'aux' field of the runner.
  2. The 'test-read-eval-string' procedure takes an optional argument
     to specify an environment argument to be passed to 'eval'.
  3. The new procedure 'test-exit' exits the running Scheme program,
     with an exit status indicating whether there have been any
     failures or unexpected passes.

* Fixes a pair of bugs that still exist in the old implementation:
  1. https://bugs.gnu.org/21181  "Possible bug in test-group"
  2. Reported via IRC: per specification, test-end should remove any
     test runner that was installed automatically by test-begin.


There is one incompatibility with the old implementation:

* The reference implementation exports a non-standard variable called
  'test-log-to-file' which can be set to #false to disable the logging
  performed by the default test runner.  In the new implementation,
  the same effect can be achieved by explicitly installing the simple
  test runner without providing the optional log-file argument:
  (current-test-runner (test-runner-simple))


So far I've had positive feedback over, with one person saying that
they've been recommending this implementation to everyone.


One might think that the reference implementation is more stable as
it has been around longer, but the very long-standing bugs in it
prove this wrong in my opinion.  I believe that the convoluted way
the code is written invites programmer mistakes and discourages
people from trying to find and fix bugs.


The second attached patch contains a small number of additions to
the SRFI-64 meta-test-suite that tests the SRFI-64 implementation.


With kind regards,

Taylan


[0] https://github.com/TaylanUB/scheme-srfis
[1] https://lists.gnu.org/archive/html/guile-devel/2021-05/msg00007.html

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

From a2ef24da83746ee91d7a2f5e494acc95faa71fec 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        |  434 +++++++
 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, 885 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 37786ed42..5710d005d 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'.
@@ -405,7 +409,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..922e12a6d
--- /dev/null
+++ b/module/srfi/srfi-64/execution.body.scm
@@ -0,0 +1,434 @@
+;; 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)))
+    (when (not runner)
+      (error "No test runner installed.  Might have been auto-removed
+by test-end if you had not installed one explicitly."))
+    (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 e2f9c8baa2d3237e8d02fdd0849666d0de1b34bd 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	[flat|nested] only message in thread

only message in thread, other threads:[~2021-05-15 14:16 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-05-15 14:16 bug#48442: [PATCH] Use a better SRFI-64 implementation Taylan Kammer

unofficial mirror of bug-guile@gnu.org 

This inbox may be cloned and mirrored by anyone:

	git clone --mirror https://yhetil.org/guile-bugs/0 guile-bugs/git/0.git

	# If you have public-inbox 1.1+ installed, you may
	# initialize and index your mirror using the following commands:
	public-inbox-init -V2 guile-bugs guile-bugs/ https://yhetil.org/guile-bugs \
		bug-guile@gnu.org
	public-inbox-index guile-bugs

Example config snippet for mirrors.
Newsgroups are available over NNTP:
	nntp://news.yhetil.org/yhetil.lisp.guile.bugs
	nntp://news.gmane.io/gmane.lisp.guile.bugs


AGPL code for this site: git clone http://ou63pmih66umazou.onion/public-inbox.git