From e7d6be3797a861a3df871e6215ff7d1a924f112e Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 29 Jan 2014 02:20:01 -0500
Subject: [PATCH] Implement SRFI-64 - A Scheme API for test suites.

* module/srfi/srfi-64.scm: New file.
* module/srfi/srfi-64/testing.scm: New file.
* module/Makefile.am: Add rule for srfi-64.go dependency on
  srfi-64/testing.scm.
  (SRFI_SOURCES): Add srfi/srfi-64.scm.
  (NOCOMP_SOURCES): Add srfi/srfi-64/testing.scm.
* doc/ref/srfi-modules.texi (SRFI-64): New node.
* test-suite/tests/srfi-64.test: New file.
* test-suite/tests/srfi-64-test.scm: New file.
* test-suite/Makefile.am (SCM_TESTS): Add test-suite/tests/srfi-64.test.
  (EXTRA_DIST): Add tests/srfi-64-test.scm.
---
 doc/ref/srfi-modules.texi         |    8 +
 module/Makefile.am                |    7 +-
 module/srfi/srfi-64.scm           |   55 ++
 module/srfi/srfi-64/testing.scm   | 1032 +++++++++++++++++++++++++++++++++++++
 test-suite/Makefile.am            |    4 +-
 test-suite/tests/srfi-64-test.scm |  934 +++++++++++++++++++++++++++++++++
 test-suite/tests/srfi-64.test     |   45 ++
 7 files changed, 2083 insertions(+), 2 deletions(-)
 create mode 100644 module/srfi/srfi-64.scm
 create mode 100644 module/srfi/srfi-64/testing.scm
 create mode 100644 test-suite/tests/srfi-64-test.scm
 create mode 100644 test-suite/tests/srfi-64.test

diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index b6e966b..59059c7 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
 * SRFI-60::                     Integers as bits.
 * SRFI-61::                     A more general `cond' clause
 * SRFI-62::                     S-expression comments.
+* SRFI-64::                     A Scheme API for test suites.
 * SRFI-67::                     Compare procedures
 * SRFI-69::                     Basic hash tables.
 * SRFI-87::                     => in case clauses.
@@ -5271,6 +5272,13 @@ needed to get SRFI-61 itself.  Extended @code{cond} is documented in
 Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS
 S-expression comments by default.
 
+@node SRFI-64
+@subsection SRFI-64 - A Scheme API for test suites.
+@cindex SRFI-64
+
+See @uref{http://srfi.schemers.org/srfi-64/srfi-64.html, the
+specification of SRFI-64}.
+
 @node SRFI-67
 @subsection SRFI-67 - Compare procedures
 @cindex SRFI-67
diff --git a/module/Makefile.am b/module/Makefile.am
index 3daa9e6..cbdbbc9 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,7 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##  	Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+##  	Copyright (C) 2009, 2010, 2011, 2012, 2013,
+##        2014 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -264,6 +265,8 @@ SCRIPTS_SOURCES +=				\
 
 endif BUILD_ICE_9_POPEN
 
+srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
+
 SRFI_SOURCES = \
   srfi/srfi-2.scm \
   srfi/srfi-4.scm \
@@ -293,6 +296,7 @@ SRFI_SOURCES = \
   srfi/srfi-39.scm \
   srfi/srfi-45.scm \
   srfi/srfi-60.scm \
+  srfi/srfi-64.scm \
   srfi/srfi-67.scm \
   srfi/srfi-69.scm \
   srfi/srfi-88.scm \
@@ -400,6 +404,7 @@ NOCOMP_SOURCES =				\
   ice-9/r6rs-libraries.scm			\
   ice-9/quasisyntax.scm				\
   srfi/srfi-42/ec.scm				\
+  srfi/srfi-64/testing.scm			\
   srfi/srfi-67/compare.scm			\
   system/base/lalr.upstream.scm			\
   system/repl/describe.scm			\
diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm
new file mode 100644
index 0000000..81dcc5d
--- /dev/null
+++ b/module/srfi/srfi-64.scm
@@ -0,0 +1,55 @@
+;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites.
+
+;;      Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-64)
+  #:export
+  (test-begin
+   test-end test-assert test-eqv test-eq test-equal
+   test-approximate test-assert test-error test-apply test-with-runner
+   test-match-nth test-match-all test-match-any test-match-name
+   test-skip test-expect-fail test-read-eval-string
+   test-runner-group-path test-group test-group-with-cleanup
+   test-result-ref test-result-set! test-result-clear test-result-remove
+   test-result-kind test-passed?
+   test-log-to-file
+   test-runner? test-runner-reset test-runner-null
+   test-runner-simple test-runner-current test-runner-factory test-runner-get
+   test-runner-create test-runner-test-name
+   test-runner-pass-count test-runner-pass-count!
+   test-runner-fail-count test-runner-fail-count!
+   test-runner-xpass-count test-runner-xpass-count!
+   test-runner-xfail-count test-runner-xfail-count!
+   test-runner-skip-count test-runner-skip-count!
+   test-runner-group-stack test-runner-group-stack!
+   test-runner-on-test-begin test-runner-on-test-begin!
+   test-runner-on-test-end test-runner-on-test-end!
+   test-runner-on-group-begin test-runner-on-group-begin!
+   test-runner-on-group-end test-runner-on-group-end!
+   test-runner-on-final test-runner-on-final!
+   test-runner-on-bad-count test-runner-on-bad-count!
+   test-runner-on-bad-end-name test-runner-on-bad-end-name!
+   test-result-alist test-result-alist!
+   test-runner-aux-value test-runner-aux-value!
+   test-on-group-begin-simple test-on-group-end-simple
+   test-on-bad-count-simple test-on-bad-end-name-simple
+   test-on-final-simple test-on-test-end-simple
+   test-on-final-simple))
+
+(cond-expand-provide (current-module) '(srfi-64))
+
+(include-from-path "srfi/srfi-64/testing.scm")
diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm
new file mode 100644
index 0000000..8313525
--- /dev/null
+++ b/module/srfi/srfi-64/testing.scm
@@ -0,0 +1,1032 @@
+;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner
+;; Added "full" support for Chicken, Gauche, Guile and SISC.
+;;   Alex Shinn, Copyright (c) 2005.
+;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012.
+;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014.
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(cond-expand
+ (chicken
+  (require-extension syntax-case))
+ (guile-2
+  (use-modules (srfi srfi-9)
+               ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated
+               ;; with either Guile's native exceptions or R6RS exceptions.
+               ;;(srfi srfi-34) (srfi srfi-35)
+               (srfi srfi-39)))
+ (guile
+  (use-modules (ice-9 syncase) (srfi srfi-9)
+	       ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7
+	       (srfi srfi-39)))
+ (sisc
+  (require-extension (srfi 9 34 35 39)))
+ (kawa
+  (module-compile-options warn-undefined-variable: #t
+			  warn-invoke-unknown-method: #t)
+  (provide 'srfi-64)
+  (provide 'testing)
+  (require 'srfi-34)
+  (require 'srfi-35))
+ (else ()
+  ))
+
+(cond-expand
+ (kawa
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export test-begin . other-names)
+       (module-export %test-begin . other-names)))))
+ (else
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export . names) (if #f #f))))))
+
+;; List of exported names
+(%test-export
+ test-begin ;; must be listed first, since in Kawa (at least) it is "magic".
+ test-end test-assert test-eqv test-eq test-equal
+ test-approximate test-assert test-error test-apply test-with-runner
+ test-match-nth test-match-all test-match-any test-match-name
+ test-skip test-expect-fail test-read-eval-string
+ test-runner-group-path test-group test-group-with-cleanup
+ test-result-ref test-result-set! test-result-clear test-result-remove
+ test-result-kind test-passed?
+ test-log-to-file
+ ; Misc test-runner functions
+ test-runner? test-runner-reset test-runner-null
+ test-runner-simple test-runner-current test-runner-factory test-runner-get
+ test-runner-create test-runner-test-name
+ ;; test-runner field setter and getter functions - see %test-record-define:
+ test-runner-pass-count test-runner-pass-count!
+ test-runner-fail-count test-runner-fail-count!
+ test-runner-xpass-count test-runner-xpass-count!
+ test-runner-xfail-count test-runner-xfail-count!
+ test-runner-skip-count test-runner-skip-count!
+ test-runner-group-stack test-runner-group-stack!
+ test-runner-on-test-begin test-runner-on-test-begin!
+ test-runner-on-test-end test-runner-on-test-end!
+ test-runner-on-group-begin test-runner-on-group-begin!
+ test-runner-on-group-end test-runner-on-group-end!
+ test-runner-on-final test-runner-on-final!
+ test-runner-on-bad-count test-runner-on-bad-count!
+ test-runner-on-bad-end-name test-runner-on-bad-end-name!
+ test-result-alist test-result-alist!
+ test-runner-aux-value test-runner-aux-value!
+ ;; default/simple call-back functions, used in default test-runner,
+ ;; but can be called to construct more complex ones.
+ test-on-group-begin-simple test-on-group-end-simple
+ test-on-bad-count-simple test-on-bad-end-name-simple
+ test-on-final-simple test-on-test-end-simple
+ test-on-final-simple)
+
+(cond-expand
+ (srfi-9
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index setter getter) ...)
+       (define-record-type test-runner
+	 (alloc)
+	 runner?
+	 (name setter getter) ...)))))
+ (else
+  (define %test-runner-cookie (list "test-runner"))
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define alloc runner? (name index getter setter) ...)
+       (begin
+	 (define (runner? obj)
+	   (and (vector? obj)
+		(> (vector-length obj) 1)
+		(eq (vector-ref obj 0) %test-runner-cookie)))
+	 (define (alloc)
+	   (let ((runner (make-vector 23)))
+	     (vector-set! runner 0 %test-runner-cookie)
+	     runner))
+	 (begin
+	   (define (getter runner)
+	     (vector-ref runner index)) ...)
+	 (begin
+	   (define (setter runner value)
+	     (vector-set! runner index value)) ...)))))))
+
+(%test-record-define
+ %test-runner-alloc test-runner?
+ ;; Cumulate count of all tests that have passed and were expected to.
+ (pass-count 1 test-runner-pass-count test-runner-pass-count!)
+ (fail-count 2 test-runner-fail-count test-runner-fail-count!)
+ (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count 5 test-runner-skip-count test-runner-skip-count!)
+ (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
+ ;; Normally #t, except when in a test-apply.
+ (run-list 8 %test-runner-run-list %test-runner-run-list!)
+ (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
+ (group-stack 11 test-runner-group-stack test-runner-group-stack!)
+ (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
+ ;; Call-back when entering a group. Takes (runner suite-name count).
+ (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
+ ;; Call-back when leaving a group.
+ (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
+ ;; Call-back when leaving the outermost group.
+ (on-final 16 test-runner-on-final test-runner-on-final!)
+ ;; Call-back when expected number of tests was wrong.
+ (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
+ ;; Call-back when name in test=end doesn't match test-begin.
+ (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ ;; Cumulate count of all tests that have been done.
+ (total-count 19 %test-runner-total-count %test-runner-total-count!)
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list 20 %test-runner-count-list %test-runner-count-list!)
+ (result-alist 21 test-result-alist test-result-alist!)
+ ;; Field can be used by test-runner for any purpose.
+ ;; test-runner-simple uses it for a log file.
+ (aux-value 22 test-runner-aux-value test-runner-aux-value!)
+)
+
+(define (test-runner-reset runner)
+  (test-result-alist! runner '())
+  (test-runner-pass-count! runner 0)
+  (test-runner-fail-count! runner 0)
+  (test-runner-xpass-count! runner 0)
+  (test-runner-xfail-count! runner 0)
+  (test-runner-skip-count! runner 0)
+  (%test-runner-total-count! runner 0)
+  (%test-runner-count-list! runner '())
+  (%test-runner-run-list! runner #t)
+  (%test-runner-skip-list! runner '())
+  (%test-runner-fail-list! runner '())
+  (%test-runner-skip-save! runner '())
+  (%test-runner-fail-save! runner '())
+  (test-runner-group-stack! runner '()))
+
+(define (test-runner-group-path runner)
+  (reverse (test-runner-group-stack runner)))
+
+(define (%test-null-callback runner) #f)
+
+(define (test-runner-null)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner (lambda (runner name count) #f))
+    (test-runner-on-group-end! runner %test-null-callback)
+    (test-runner-on-final! runner %test-null-callback)
+    (test-runner-on-test-begin! runner %test-null-callback)
+    (test-runner-on-test-end! runner %test-null-callback)
+    (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
+    (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
+    runner))
+
+;; Not part of the specification.  FIXME
+;; Controls whether a log file is generated.
+(define test-log-to-file #t)
+
+(define (test-runner-simple)
+  (let ((runner (%test-runner-alloc)))
+    (test-runner-reset runner)
+    (test-runner-on-group-begin! runner test-on-group-begin-simple)
+    (test-runner-on-group-end! runner test-on-group-end-simple)
+    (test-runner-on-final! runner test-on-final-simple)
+    (test-runner-on-test-begin! runner test-on-test-begin-simple)
+    (test-runner-on-test-end! runner test-on-test-end-simple)
+    (test-runner-on-bad-count! runner test-on-bad-count-simple)
+    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+    runner))
+
+(cond-expand
+ (srfi-39
+  (define test-runner-current (make-parameter #f))
+  (define test-runner-factory (make-parameter test-runner-simple)))
+ (else
+  (define %test-runner-current #f)
+  (define-syntax test-runner-current
+    (syntax-rules ()
+      ((test-runner-current)
+       %test-runner-current)
+      ((test-runner-current runner)
+       (set! %test-runner-current runner))))
+  (define %test-runner-factory test-runner-simple)
+  (define-syntax test-runner-factory
+    (syntax-rules ()
+      ((test-runner-factory)
+       %test-runner-factory)
+      ((test-runner-factory runner)
+       (set! %test-runner-factory runner))))))
+
+;; A safer wrapper to test-runner-current.
+(define (test-runner-get)
+  (let ((r (test-runner-current)))
+    (if (not r)
+	(cond-expand
+	 (srfi-23 (error "test-runner not initialized - test-begin missing?"))
+	 (else #t)))
+    r))
+
+(define (%test-specifier-matches spec runner)
+  (spec runner))
+
+(define (test-runner-create)
+  ((test-runner-factory)))
+
+(define (%test-any-specifier-matches list runner)
+  (let ((result #f))
+    (let loop ((l list))
+      (cond ((null? l) result)
+	    (else
+	     (if (%test-specifier-matches (car l) runner)
+		 (set! result #t))
+	     (loop (cdr l)))))))
+
+;; Returns #f, #t, or 'xfail.
+(define (%test-should-execute runner)
+  (let ((run (%test-runner-run-list runner)))
+    (cond ((or
+	    (not (or (eqv? run #t)
+		     (%test-any-specifier-matches run runner)))
+	    (%test-any-specifier-matches
+	     (%test-runner-skip-list runner)
+	     runner))
+	    (test-result-set! runner 'result-kind 'skip)
+	    #f)
+	  ((%test-any-specifier-matches
+	    (%test-runner-fail-list runner)
+	    runner)
+	   (test-result-set! runner 'result-kind 'xfail)
+	   'xfail)
+	  (else #t))))
+
+(define (%test-begin suite-name count)
+  (if (not (test-runner-current))
+      (test-runner-current (test-runner-create)))
+  (let ((runner (test-runner-current)))
+    ((test-runner-on-group-begin runner) runner suite-name count)
+    (%test-runner-skip-save! runner
+			       (cons (%test-runner-skip-list runner)
+				     (%test-runner-skip-save runner)))
+    (%test-runner-fail-save! runner
+			       (cons (%test-runner-fail-list runner)
+				     (%test-runner-fail-save runner)))
+    (%test-runner-count-list! runner
+			     (cons (cons (%test-runner-total-count runner)
+					 count)
+				   (%test-runner-count-list runner)))
+    (test-runner-group-stack! runner (cons suite-name
+					(test-runner-group-stack runner)))))
+(cond-expand
+ (kawa
+  ;; Kawa has test-begin built in, implemented as:
+  ;; (begin
+  ;;   (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
+  ;;   (%test-begin suite-name [count]))
+  ;; This puts test-begin but only test-begin in the default environment.,
+  ;; which makes normal test suites loadable without non-portable commands.
+  )
+ (else
+  (define-syntax test-begin
+    (syntax-rules ()
+      ((test-begin suite-name)
+       (%test-begin suite-name #f))
+      ((test-begin suite-name count)
+       (%test-begin suite-name count))))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+  (if (null? (test-runner-group-stack runner))
+      (begin
+	(display "%%%% Starting test ")
+	(display suite-name)
+	(if test-log-to-file
+	    (let* ((log-file-name
+		    (if (string? test-log-to-file) test-log-to-file
+			(string-append suite-name ".log")))
+		   (log-file
+		    (cond-expand (mzscheme
+				  (open-output-file log-file-name 'truncate/replace))
+				 (else (open-output-file log-file-name)))))
+	      (display "%%%% Starting test " log-file)
+	      (display suite-name log-file)
+	      (newline log-file)
+	      (test-runner-aux-value! runner log-file)
+	      (display "  (Writing full log to \"")
+	      (display log-file-name)
+	      (display "\")")))
+	(newline)))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group begin: " log)
+	  (display suite-name log)
+	  (newline log))))
+  #f)
+
+(define (test-on-group-end-simple runner)
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(begin
+	  (display "Group end: " log)
+	  (display (car (test-runner-group-stack runner)) log)
+	  (newline log))))
+  #f)
+
+(define (%test-on-bad-count-write runner count expected-count port)
+  (display "*** Total number of tests was " port)
+  (display count port)
+  (display " but should be " port)
+  (display expected-count port)
+  (display ". ***" port)
+  (newline port)
+  (display "*** Discrepancy indicates testsuite error or exceptions. ***" port)
+  (newline port))
+
+(define (test-on-bad-count-simple runner count expected-count)
+  (%test-on-bad-count-write runner count expected-count (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-on-bad-count-write runner count expected-count log))))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+  (let ((msg (string-append (%test-format-line runner) "test-end " begin-name
+			    " does not match test-begin " end-name)))
+    (cond-expand
+     (srfi-23 (error msg))
+     (else (display msg) (newline)))))
+  
+
+(define (%test-final-report1 value label port)
+  (if (> value 0)
+      (begin
+	(display label port)
+	(display value port)
+	(newline port))))
+
+(define (%test-final-report-simple runner port)
+  (%test-final-report1 (test-runner-pass-count runner)
+		      "# of expected passes      " port)
+  (%test-final-report1 (test-runner-xfail-count runner)
+		      "# of expected failures    " port)
+  (%test-final-report1 (test-runner-xpass-count runner)
+		      "# of unexpected successes " port)
+  (%test-final-report1 (test-runner-fail-count runner)
+		      "# of unexpected failures  " port)
+  (%test-final-report1 (test-runner-skip-count runner)
+		      "# of skipped tests        " port))
+
+(define (test-on-final-simple runner)
+  (%test-final-report-simple runner (current-output-port))
+  (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(%test-final-report-simple runner log))))
+
+(define (%test-format-line runner)
+   (let* ((line-info (test-result-alist runner))
+	  (source-file (assq 'source-file line-info))
+	  (source-line (assq 'source-line line-info))
+	  (file (if source-file (cdr source-file) "")))
+     (if source-line
+	 (string-append file ":"
+			(number->string (cdr source-line)) ": ")
+	 "")))
+
+(define (%test-end suite-name line-info)
+  (let* ((r (test-runner-get))
+	 (groups (test-runner-group-stack r))
+	 (line (%test-format-line r)))
+    (test-result-alist! r line-info)
+    (if (null? groups)
+	(let ((msg (string-append line "test-end not in a group")))
+	  (cond-expand
+	   (srfi-23 (error msg))
+	   (else (display msg) (newline)))))
+    (if (and suite-name (not (equal? suite-name (car groups))))
+	((test-runner-on-bad-end-name r) r suite-name (car groups)))
+    (let* ((count-list (%test-runner-count-list r))
+	   (expected-count (cdar count-list))
+	   (saved-count (caar count-list))
+	   (group-count (- (%test-runner-total-count r) saved-count)))
+      (if (and expected-count
+	       (not (= expected-count group-count)))
+	  ((test-runner-on-bad-count r) r group-count expected-count))
+      ((test-runner-on-group-end r) r)
+      (test-runner-group-stack! r (cdr (test-runner-group-stack r)))
+      (%test-runner-skip-list! r (car (%test-runner-skip-save r)))
+      (%test-runner-skip-save! r (cdr (%test-runner-skip-save r)))
+      (%test-runner-fail-list! r (car (%test-runner-fail-save r)))
+      (%test-runner-fail-save! r (cdr (%test-runner-fail-save r)))
+      (%test-runner-count-list! r (cdr count-list))
+      (if (null? (test-runner-group-stack r))
+	  ((test-runner-on-final r) r)))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((test-group suite-name . body)
+     (let ((r (test-runner-current)))
+       ;; Ideally should also set line-number, if available.
+       (test-result-alist! r (list (cons 'test-name suite-name)))
+       (if (%test-should-execute r)
+	   (dynamic-wind
+	       (lambda () (test-begin suite-name))
+	       (lambda () . body)
+	       (lambda () (test-end  suite-name))))))))
+
+(define-syntax test-group-with-cleanup
+  (syntax-rules ()
+    ((test-group-with-cleanup suite-name form cleanup-form)
+     (test-group suite-name
+		    (dynamic-wind
+			(lambda () #f)
+			(lambda () form)
+			(lambda () cleanup-form))))
+    ((test-group-with-cleanup suite-name cleanup-form)
+     (test-group-with-cleanup suite-name #f cleanup-form))
+    ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
+     (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
+
+(define (test-on-test-begin-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+    (if (output-port? log)
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (source-form (assq 'source-form results))
+	       (test-name (assq 'test-name results)))
+	  (display "Test begin:" log)
+	  (newline log)
+	  (if test-name (%test-write-result1 test-name log))
+	  (if source-file (%test-write-result1 source-file log))
+	  (if source-line (%test-write-result1 source-line log))
+	  (if source-form (%test-write-result1 source-form log))))))
+
+(define-syntax test-result-ref
+  (syntax-rules ()
+    ((test-result-ref runner pname)
+     (test-result-ref runner pname #f))
+    ((test-result-ref runner pname default)
+     (let ((p (assq pname (test-result-alist runner))))
+       (if p (cdr p) default)))))
+
+(define (test-on-test-end-simple runner)
+  (let ((log (test-runner-aux-value runner))
+	(kind (test-result-ref runner 'result-kind)))
+    (if (memq kind '(fail xpass))
+	(let* ((results (test-result-alist runner))
+	       (source-file (assq 'source-file results))
+	       (source-line (assq 'source-line results))
+	       (test-name (assq 'test-name results)))
+	  (if (or source-file source-line)
+	      (begin
+		(if source-file (display (cdr source-file)))
+		(display ":")
+		(if source-line (display (cdr source-line)))
+		(display ": ")))
+	  (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
+	  (if test-name
+	      (begin
+		(display " ")
+		(display (cdr test-name))))
+	  (newline)))
+    (if (output-port? log)
+	(begin
+	  (display "Test end:" log)
+	  (newline log)
+	  (let loop ((list (test-result-alist runner)))
+	    (if (pair? list)
+		(let ((pair (car list)))
+		  ;; Write out properties not written out by on-test-begin.
+		  (if (not (memq (car pair)
+				 '(test-name source-file source-line source-form)))
+		      (%test-write-result1 pair log))
+		  (loop (cdr list)))))))))
+
+(define (%test-write-result1 pair port)
+  (display "  " port)
+  (display (car pair) port)
+  (display ": " port)
+  (write (cdr pair) port)
+  (newline port))
+
+(define (test-result-set! runner pname value)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(set-cdr! p value)
+	(test-result-alist! runner (cons (cons pname value) alist)))))
+
+(define (test-result-clear runner)
+  (test-result-alist! runner '()))
+
+(define (test-result-remove runner pname)
+  (let* ((alist (test-result-alist runner))
+	 (p (assq pname alist)))
+    (if p
+	(test-result-alist! runner
+				   (let loop ((r alist))
+				     (if (eq? r p) (cdr r)
+					 (cons (car r) (loop (cdr r)))))))))
+
+(define (test-result-kind . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
+    (test-result-ref runner 'result-kind)))
+
+(define (test-passed? . rest)
+  (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
+    (memq (test-result-ref runner 'result-kind) '(pass xpass))))
+
+(define (%test-report-result)
+  (let* ((r (test-runner-get))
+	 (result-kind (test-result-kind r)))
+    (case result-kind
+      ((pass)
+       (test-runner-pass-count! r (+ 1 (test-runner-pass-count r))))
+      ((fail)
+       (test-runner-fail-count!	r (+ 1 (test-runner-fail-count r))))
+      ((xpass)
+       (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r))))
+      ((xfail)
+       (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r))))
+      (else
+       (test-runner-skip-count! r (+ 1 (test-runner-skip-count r)))))
+    (%test-runner-total-count! r (+ 1 (%test-runner-total-count r)))
+    ((test-runner-on-test-end r) r)))
+
+(cond-expand
+ (guile
+  (define-syntax %test-evaluate-with-catch
+    (syntax-rules ()
+      ((%test-evaluate-with-catch test-expression)
+       (catch #t (lambda () test-expression) (lambda (key . args) #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-approximimate= 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-approximimate= error) expected expr))))
+      (((mac expected expr error) line)
+       (syntax
+	(let* ((r (test-runner-get)))
+	  (test-result-alist! r line)
+	  (%test-comp2body r (%test-approximimate= 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-approximimate= error) tname expected expr))
+      ((test-approximate expected expr error)
+       (%test-comp2 (%test-approximimate= 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-assert name (%test-error r etype expr))))
+      ((test-error etype expr)
+       (let ((r (test-runner-get)))
+         (test-assert (%test-error r etype expr))))
+      ((test-error expr)
+       (let ((r (test-runner-get)))
+         (test-assert (%test-error r #t expr))))))))
+
+(define (test-apply first . rest)
+  (if (test-runner? first)
+      (test-with-runner first (apply test-apply rest))
+      (let ((r (test-runner-current)))
+	(if r
+	    (let ((run-list (%test-runner-run-list r)))
+	      (cond ((null? rest)
+		     (%test-runner-run-list! r (reverse run-list))
+		     (first)) ;; actually apply procedure thunk
+		    (else
+		     (%test-runner-run-list!
+		      r
+		      (if (eq? run-list #t) (list first) (cons first run-list)))
+		     (apply test-apply rest)
+		     (%test-runner-run-list! r run-list))))
+	    (let ((r (test-runner-create)))
+	      (test-with-runner r (apply test-apply first rest))
+	      ((test-runner-on-final r) r))))))
+
+(define-syntax test-with-runner
+  (syntax-rules ()
+    ((test-with-runner runner form ...)
+     (let ((saved-runner (test-runner-current)))
+       (dynamic-wind
+           (lambda () (test-runner-current runner))
+           (lambda () form ...)
+           (lambda () (test-runner-current saved-runner)))))))
+
+;;; Predicates
+
+(define (%test-match-nth n count)
+  (let ((i 0))
+    (lambda (runner)
+      (set! i (+ i 1))
+      (and (>= i n) (< i (+ n count))))))
+
+(define-syntax test-match-nth
+  (syntax-rules ()
+    ((test-match-nth n)
+     (test-match-nth n 1))
+    ((test-match-nth n count)
+     (%test-match-nth n count))))
+
+(define (%test-match-all . pred-list)
+  (lambda (runner)
+    (let ((result #t))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if (not ((car l) runner))
+		  (set! result #f))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-all
+  (syntax-rules ()
+    ((test-match-all pred ...)
+     (%test-match-all (%test-as-specifier pred) ...))))
+
+(define (%test-match-any . pred-list)
+  (lambda (runner)
+    (let ((result #f))
+      (let loop ((l pred-list))
+	(if (null? l)
+	    result
+	    (begin
+	      (if ((car l) runner)
+		  (set! result #t))
+	      (loop (cdr l))))))))
+  
+(define-syntax test-match-any
+  (syntax-rules ()
+    ((test-match-any pred ...)
+     (%test-match-any (%test-as-specifier pred) ...))))
+
+;; Coerce to a predicate function:
+(define (%test-as-specifier specifier)
+  (cond ((procedure? specifier) specifier)
+	((integer? specifier) (test-match-nth 1 specifier))
+	((string? specifier) (test-match-name specifier))
+	(else
+	 (error "not a valid test specifier"))))
+
+(define-syntax test-skip
+  (syntax-rules ()
+    ((test-skip pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-skip-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-skip-list runner)))))))
+
+(define-syntax test-expect-fail
+  (syntax-rules ()
+    ((test-expect-fail pred ...)
+     (let ((runner (test-runner-get)))
+       (%test-runner-fail-list! runner
+				  (cons (test-match-all (%test-as-specifier pred)  ...)
+					(%test-runner-fail-list runner)))))))
+
+(define (test-match-name name)
+  (lambda (runner)
+    (equal? name (test-runner-test-name runner))))
+
+(define (test-read-eval-string string)
+  (let* ((port (open-input-string string))
+	 (form (read port)))
+    (if (eof-object? (read-char port))
+	(cond-expand
+	 (guile (eval form (current-module)))
+	 (else (eval form)))
+	(cond-expand
+	 (srfi-23 (error "(not at eof)"))
+	 (else "error")))))
+
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index b148b54..7578bf5 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test		\
 	    tests/srfi-43.test			\
 	    tests/srfi-45.test			\
 	    tests/srfi-60.test			\
+	    tests/srfi-64.test			\
 	    tests/srfi-67.test			\
 	    tests/srfi-69.test			\
 	    tests/srfi-88.test			\
@@ -174,7 +175,8 @@ EXTRA_DIST = \
 	guile-test \
 	test-suite/lib.scm \
 	$(SCM_TESTS) \
-	tests/rnrs-test-a.scm
+	tests/rnrs-test-a.scm \
+	tests/srfi-64-test.scm \
 	ChangeLog-2008
 
 
diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm
new file mode 100644
index 0000000..3cd67d0
--- /dev/null
+++ b/test-suite/tests/srfi-64-test.scm
@@ -0,0 +1,934 @@
+;;;
+;;;  This is a test suite written in the notation of 
+;;;  SRFI-64, A Scheme API for test suites
+;;;
+
+(test-begin "SRFI 64 - Meta-Test Suite")
+
+;;;
+;;;  Ironically, in order to set up the meta-test environment,
+;;;  we have to invoke one of the most sophisticated features:
+;;;  custom test runners
+;;;
+
+;;;  The `prop-runner' invokes `thunk' in the context of a new
+;;;  test runner, and returns the indicated properties of the 
+;;;  last-executed test result.
+
+(define (prop-runner props thunk)
+  (let ((r (test-runner-null))
+        (plist '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! plist (test-result-alist runner))))
+    ;;
+    (test-with-runner r (thunk))
+    ;; reorder the properties so they are in the order
+    ;; given by `props'.  Note that any property listed in `props'
+    ;; that is not in the property alist will occur as #f
+    (map (lambda (k)
+           (assq k plist))
+         props)))
+
+;;;  `on-test-runner' creates a null test runner and then
+;;;  arranged for `visit' to be called with the runner
+;;;  whenever a test is run.  The results of the calls to
+;;;  `visit' are returned in a list
+
+(define (on-test-runner thunk visit)
+  (let ((r (test-runner-null))
+        (results '()))
+    ;;
+    (test-runner-on-test-end!
+     r
+     (lambda (runner)
+       (set! results (cons (visit r) results))))
+    ;;
+    (test-with-runner r (thunk))
+    (reverse results)))
+
+;;;
+;;;  The `triv-runner' invokes `thunk'
+;;;  and returns a list of 6 lists, the first 5 of which
+;;;  are a list of the names of the tests that, respectively,
+;;;  PASS, FAIL, XFAIL, XPASS, and SKIP.
+;;;  The last item is a list of counts.
+;;;
+
+(define (triv-runner thunk)
+  (let ((r (test-runner-null))
+        (accum-pass '())
+        (accum-fail '())
+        (accum-xfail '())
+        (accum-xpass '())
+        (accum-skip '()))
+    ;;
+    (test-runner-on-bad-count!
+     r
+     (lambda (runner count expected-count)
+       (error (string-append "bad count " (number->string count)
+			     " but expected "
+			     (number->string expected-count)))))
+    (test-runner-on-bad-end-name!
+     r
+     (lambda (runner begin end)
+       (error (string-append "bad end group name " end
+			     " but expected " begin))))
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (let ((n (test-runner-test-name runner)))
+         (case (test-result-kind runner)
+           ((pass) (set! accum-pass (cons n accum-pass)))
+           ((fail) (set! accum-fail (cons n accum-fail)))
+           ((xpass) (set! accum-xpass (cons n accum-xpass)))
+           ((xfail) (set! accum-xfail (cons n accum-xfail)))
+           ((skip) (set! accum-skip (cons n accum-skip)))))))
+    ;;
+    (test-with-runner r (thunk))
+    (list (reverse accum-pass)    ; passed as expected
+          (reverse accum-fail)    ; failed, but was expected to pass
+          (reverse accum-xfail)   ; failed as expected
+          (reverse accum-xpass)   ; passed, but was expected to fail
+          (reverse accum-skip)    ; was not executed
+          (list (test-runner-pass-count r)
+                (test-runner-fail-count r)
+                (test-runner-xfail-count r)
+                (test-runner-xpass-count r)
+                (test-runner-skip-count r)))))
+
+(define (path-revealing-runner thunk)
+  (let ((r (test-runner-null))
+        (seq '()))
+    ;;
+    (test-runner-on-test-end! 
+     r 
+     (lambda (runner)
+       (set! seq (cons (list (test-runner-group-path runner)
+                             (test-runner-test-name runner))
+                       seq))))
+    (test-with-runner r (thunk))
+    (reverse seq)))
+
+;;;
+;;;  Now we can start testing compliance with SRFI-64
+;;;
+
+(test-begin "1. Simple test-cases")
+
+(test-begin "1.1. test-assert")
+
+(define (t)
+  (triv-runner
+   (lambda ()
+     (test-assert "a" #t)
+     (test-assert "b" #f))))
+
+(test-equal
+ "1.1.1. Very simple"
+ '(("a") ("b") () () () (1 1 0 0 0))
+ (t))
+
+(test-equal
+ "1.1.2. A test with no name"
+ '(("a") ("") () () () (1 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert #f))))
+
+(test-equal
+ "1.1.3. Tests can have the same name"
+ '(("a" "a") () () () () (2 0 0 0 0))
+ (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t))))
+
+(define (choke)
+  (vector-ref '#(1 2) 3))
+
+(test-equal
+ "1.1.4. One way to FAIL is to throw an error"
+ '(() ("a") () () () (0 1 0 0 0))
+ (triv-runner (lambda () (test-assert "a" (choke)))))
+
+(test-end);1.1
+
+(test-begin "1.2. test-eqv")
+
+(define (mean x y)
+  (/ (+ x y) 2.0))
+
+(test-equal
+ "1.2.1.  Simple numerical equivalence"
+ '(("c") ("a" "b") () () () (1 2 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-eqv "a" (mean 3 5) 4)
+    (test-eqv "b" (mean 3 5) 4.5)
+    (test-eqv "c" (mean 3 5) 4.0))))
+
+(test-end);1.2
+
+(test-end "1. Simple test-cases")
+
+;;;
+;;;
+;;;
+
+(test-begin "2. Tests for catching errors")
+
+(test-begin "2.1. test-error")
+
+(test-equal
+ "2.1.1. Baseline test; PASS with no optional args"
+ '(("") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error (vector-ref '#(1 2) 9)))))
+
+(test-equal
+ "2.1.2. Baseline test; FAIL with no optional args"
+ '(() ("") () () () (0 1 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; FAIL: the expr does not raise an error and `test-error' is
+    ;;       claiming that it will, so this test should FAIL
+    (test-error (vector-ref '#(1 2) 0)))))
+
+(test-equal
+ "2.1.3. PASS with a test name and error type"
+ '(("a") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    ;; PASS
+    (test-error "a" #t (vector-ref '#(1 2) 9)))))
+
+(test-end "2.1. test-error")
+
+(test-end "2. Tests for catching errors")
+
+;;;
+;;;
+;;;
+
+(test-begin "3. Test groups and paths")
+
+(test-equal
+ "3.1. test-begin with unspecific test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end))))
+
+(test-equal
+ "3.2. test-begin with name-matching test-end"
+ '(("b") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+;;; since the error raised by `test-end' on a mismatch is not a test
+;;; error, we actually expect the triv-runner itself to fail
+
+(test-error
+ "3.3. test-begin with mismatched test-end"
+#t
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-assert "b" #t)
+    (test-end "x"))))
+
+(test-equal
+ "3.4. test-begin with name and count"
+ '(("b" "c") () () () () (2 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 2)
+    (test-assert "b" #t)
+    (test-assert "c" #t)
+    (test-end "a"))))
+
+;; similarly here, a mismatched count is a lexical error
+;; and not a test failure...
+
+(test-error
+ "3.5. test-begin with mismatched count"
+ #t
+ (triv-runner
+  (lambda ()
+    (test-begin "a" 99)
+    (test-assert "b" #t)
+    (test-end "a"))))
+
+(test-equal
+ "3.6. introspecting on the group path"
+ '((() "w")
+   (("a" "b") "x")
+   (("a" "b") "y")
+   (("a") "z"))
+ ;;
+ ;;  `path-revealing-runner' is designed to return a list
+ ;;  of the tests executed, in order.  Each entry is a list
+ ;;  (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list
+ ;;  of test groups starting from the topmost
+ ;;
+ (path-revealing-runner
+  (lambda ()
+    (test-assert "w" #t)
+    (test-begin "a")
+    (test-begin "b")
+    (test-assert "x" #t)
+    (test-assert "y" #t)
+    (test-end)
+    (test-assert "z" #t))))
+
+
+(test-end "3. Test groups and paths")
+
+;;;
+;;;
+;;;
+
+(test-begin "4. Handling set-up and cleanup")
+
+(test-equal "4.1. Normal exit path"
+             '(in 1 2 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-group-with-cleanup
+                   "foo"
+                   (do 'in)
+                   (do 1)
+                   (do 2)
+                   (do 'out))))
+               (reverse ex)))
+               
+(test-equal "4.2. Exception exit path"
+             '(in 1 out)
+             (let ((ex '()))
+               (define (do s)
+                 (set! ex (cons s ex)))
+               ;;
+               ;; the outer runner is to run the `test-error' in, to
+               ;; catch the exception raised in the inner runner,
+               ;; since we don't want to depend on any other
+               ;; exception-catching support
+               ;;
+               (triv-runner
+                (lambda ()
+                  (test-error
+                   (triv-runner
+                    (lambda ()
+                      (test-group-with-cleanup
+                       "foo"
+                       (do 'in) (test-assert #t)
+                       (do 1)   (test-assert #t)
+                       (choke)  (test-assert #t)
+                       (do 2)   (test-assert #t)
+                       (do 'out)))))))
+               (reverse ex)))
+
+(test-end "4. Handling set-up and cleanup")
+
+;;;
+;;;
+;;;
+
+(test-begin "5. Test specifiers")
+
+(test-begin "5.1. test-match-named")
+
+(test-equal "5.1.1. match test names"
+            '(("y") () () () ("x") (1 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-assert "x" #t)
+               (test-assert "y" #t))))
+
+(test-equal "5.1.2. but not group names"
+            '(("z") () () () () (1 0 0 0 0))
+            (triv-runner
+             (lambda ()
+               (test-skip (test-match-name "x"))
+               (test-begin "x")
+               (test-assert "z" #t)
+               (test-end))))
+
+(test-end)
+
+(test-begin "5.2. test-match-nth")
+;; See also: [6.4. Short-circuit evaluation]
+
+(test-equal "5.2.1. skip the nth one after"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.2.2. skip m, starting at n"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-nth 2 2))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP
+               (test-assert "y" #t)             ; 3 SKIP
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.3. test-match-any")
+(test-equal "5.3.1. basic disjunction"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-nth 3)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.3.2. disjunction is commutative"
+            '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-any (test-match-name "x")
+                                          (test-match-nth 3)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-begin "5.4. test-match-all")
+(test-equal "5.4.1. basic conjunction"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-nth 2 2)
+                                          (test-match-name "x")))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-equal "5.4.2. conjunction is commutative"
+            '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-assert "v" #t)
+               (test-skip (test-match-all (test-match-name "x")
+                                          (test-match-nth 2 2)))
+               (test-assert "w" #t)             ; 1
+               (test-assert "x" #t)             ; 2 SKIP(NAME) & SKIP(COUNT)
+               (test-assert "y" #t)             ; 3 SKIP(COUNT)
+               (test-assert "z" #t))))          ; 4
+
+(test-end)
+
+(test-end "5. Test specifiers")
+
+;;;
+;;;
+;;;
+
+(test-begin "6. Skipping selected tests")
+
+(test-equal
+ "6.1. Skip by specifier - match-name"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-name "y"))
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-equal
+ "6.2. Shorthand specifiers"
+ '(("x") () () () ("y") (1 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-begin "6.3. Specifier Stack")
+
+(test-equal
+ "6.3.1. Clearing the Specifier Stack"
+ '(("x" "x") ("y") () () ("y") (2 1 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; FAIL
+    (test-end))))
+
+(test-equal
+ "6.3.2. Inheriting the Specifier Stack"
+ '(("x" "x") () () () ("y" "y") (2 0 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-skip "y")
+    (test-begin "a")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end)
+    (test-begin "b")
+    (test-assert "x" #t)      ; PASS
+    (test-assert "y" #f)      ; SKIP
+    (test-end))))
+
+(test-end);6.3
+
+(test-begin "6.4. Short-circuit evaluation")
+
+(test-equal
+ "6.4.1. In test-match-all"
+ '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip (test-match-all "y" (test-match-nth 2)))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  FAIL
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-equal
+ "6.4.2. In separate skip-list entries"
+ '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "y")
+    (test-skip (test-match-nth 2))
+    ;; let's label the substructure forms so we can
+    ;; see which one `test-match-nth' is going to skip
+    ;;                        ; #   "y"  2   result
+    (test-assert "x" #t)      ; 1 - #f   #f  PASS   
+    (test-assert "y" #f)      ; 2 - #t   #t  SKIP 
+    (test-assert "y" #f)      ; 3 - #t   #f  SKIP
+    (test-assert "x" #f)      ; 4 - #f   #f  FAIL
+    (test-assert "z" #f)      ; 5 - #f   #f  FAIL
+    (test-end))))
+
+(test-begin "6.4.3. Skipping test suites")
+
+(test-equal
+ "6.4.3.1. Introduced using 'test-begin'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-begin "b")            ; not skipped
+    (test-assert "x" #t)
+    (test-end "b")
+    (test-end "a"))))
+
+(test-expect-fail 1) ;; ???
+(test-equal
+ "6.4.3.2. Introduced using 'test-group'"
+ '(() () () () () (0 0 0 0 1))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "b")
+    (test-group 
+     "b"            ; skipped
+     (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-equal
+ "6.4.3.3. Non-skipped 'test-group'"
+ '(("x") () () () () (1 0 0 0 0))
+ (triv-runner
+  (lambda ()
+    (test-begin "a")
+    (test-skip "c")
+    (test-group "b" (test-assert "x" #t))
+    (test-end "a"))))
+
+(test-end) ; 6.4.3
+ 
+(test-end);6.4
+
+(test-end "6. Skipping selected tests")
+
+;;;
+;;;
+;;;
+
+(test-begin "7. Expected failures")
+
+(test-equal "7.1. Simple example"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" #f))))
+
+(test-equal "7.2. Expected exception"
+            '(() ("x") ("z") () () (0 1 1 0 0))
+            (triv-runner
+             (lambda ()
+               (test-assert "x" #f)
+               (test-expect-fail "z")
+               (test-assert "z" (choke)))))
+
+(test-equal "7.3. Unexpectedly PASS"
+            '(() () ("y") ("x") () (0 0 1 1 0))
+            (triv-runner
+             (lambda ()
+               (test-expect-fail "x")
+               (test-expect-fail "y")
+               (test-assert "x" #t)
+               (test-assert "y" #f))))
+               
+
+
+(test-end "7. Expected failures")
+
+;;;
+;;;
+;;;
+
+(test-begin "8. Test-runner")
+
+;;;
+;;;  Because we want this test suite to be accurate even
+;;;  when the underlying implementation chooses to use, e.g.,
+;;;  a global variable to implement what could be thread variables
+;;;  or SRFI-39 parameter objects, we really need to save and restore
+;;;  their state ourselves
+;;;
+(define (with-factory-saved thunk)
+  (let* ((saved (test-runner-factory))
+         (result (thunk)))
+    (test-runner-factory saved)
+    result))
+
+(test-begin "8.1. test-runner-current")
+(test-assert "8.1.1. automatically restored"
+             (let ((a 0)
+                   (b 1)
+                   (c 2))
+               ;
+               (triv-runner
+                (lambda ()
+                  (set! a (test-runner-current))
+                  ;;
+                  (triv-runner
+                   (lambda ()
+                     (set! b (test-runner-current))))
+                  ;;
+                  (set! c (test-runner-current))))
+               ;;
+               (and (eq? a c)
+                    (not (eq? a b)))))
+              
+(test-end)
+
+(test-begin "8.2. test-runner-simple")
+(test-assert "8.2.1. default on-test hook"
+             (eq? (test-runner-on-test-end (test-runner-simple))
+                  test-on-test-end-simple))
+(test-assert "8.2.2. default on-final hook"
+             (eq? (test-runner-on-final (test-runner-simple))
+                  test-on-final-simple))
+(test-end)
+
+(test-begin "8.3. test-runner-factory")
+
+(test-assert "8.3.1. default factory"
+             (eq? (test-runner-factory) test-runner-simple))
+
+(test-assert "8.3.2. settable factory"
+             (with-factory-saved
+              (lambda ()
+                (test-runner-factory test-runner-null)
+                ;; we have no way, without bringing in other SRFIs,
+                ;; to make sure the following doesn't print anything,
+                ;; but it shouldn't:
+                (test-with-runner
+                 (test-runner-create)
+                 (lambda ()
+                   (test-begin "a")
+                   (test-assert #t)             ; pass
+                   (test-assert #f)             ; fail
+                   (test-assert (vector-ref '#(3) 10))  ; fail with error
+                   (test-end "a")))
+                (eq? (test-runner-factory) test-runner-null))))
+                
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2
+
+(test-begin "8.4. test-runner-create")
+(test-end)
+
+;;; This got tested about as well as it could in 8.3.2 
+
+(test-begin "8.5. test-runner-factory")
+(test-end)
+
+(test-begin "8.6. test-apply")
+(test-equal "8.6.1. Simple (form 1) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-equal "8.6.2. Simple (form 2) test-apply"
+            '(("w" "p" "v") () () () ("x") (3 0 0 0 1))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (lambda ()
+                  (test-begin "p")
+                  (test-assert "x" #t)
+                  (test-end)
+                  (test-begin "z")
+                  (test-assert "p" #t)  ; only this one should execute in here
+                  (test-end)))
+               (test-assert "v" #t))))
+
+(test-expect-fail 1) ;; depends on all test-match-nth being called.
+(test-equal "8.6.3. test-apply with skips"
+            '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3))
+            (triv-runner
+             (lambda ()
+               (test-begin "a")
+               (test-assert "w" #t)
+               (test-skip (test-match-nth 2))
+               (test-skip (test-match-nth 4))
+               (test-apply
+                (test-runner-current)
+                (test-match-name "p")
+                (test-match-name "q")
+                (lambda ()
+                                        ; only execute if SKIP=no and APPLY=yes
+                  (test-assert "x" #t)  ; # 1 SKIP=no  APPLY=no
+                  (test-assert "p" #t)  ; # 2 SKIP=yes APPLY=yes
+                  (test-assert "q" #t)  ; # 3 SKIP=no  APPLY=yes
+                  (test-assert "x" #f)  ; # 4 SKIP=yes APPLY=no
+                  0))
+               (test-assert "v" #t))))
+
+;;;  Unfortunately, since there is no way to UNBIND the current test runner,
+;;;  there is no way to test the behavior of `test-apply' in the absence
+;;;  of a current runner within our little meta-test framework.
+;;;
+;;;  To test the behavior manually, you should be able to invoke:
+;;;
+;;;     (test-apply "a" (lambda () (test-assert "a" #t)))
+;;;
+;;;  from the top level (with SRFI 64 available) and it should create a
+;;;  new, default (simple) test runner.
+
+(test-end)
+
+;;;  This entire suite depends heavily on 'test-with-runner'.  If it didn't
+;;;  work, this suite would probably go down in flames
+(test-begin "8.7. test-with-runner")
+(test-end)
+
+;;;  Again, this suite depends heavily on many of the test-runner
+;;;  components.  We'll just test those that aren't being exercised
+;;;  by the meta-test framework
+(test-begin "8.8. test-runner components")
+
+(define (auxtrack-runner thunk)
+  (let ((r (test-runner-null)))
+    (test-runner-aux-value! r '())
+    (test-runner-on-test-end! r (lambda (r)
+                              (test-runner-aux-value!
+                               r
+                               (cons (test-runner-test-name r)
+                                     (test-runner-aux-value r)))))
+    (test-with-runner r (thunk))
+    (reverse (test-runner-aux-value r))))
+
+(test-equal "8.8.1. test-runner-aux-value"
+            '("x" "" "y")
+            (auxtrack-runner
+             (lambda ()
+               (test-assert "x" #t)
+               (test-begin "a")
+               (test-assert #t)
+               (test-end)
+               (test-assert "y" #f))))
+
+(test-end) ; 8.8
+
+(test-end "8. Test-runner")
+
+(test-begin "9. Test Result Properties")
+
+(test-begin "9.1. test-result-alist")
+
+(define (symbol-alist? l)
+  (if (null? l)
+      #t
+      (and (pair? l)
+           (pair? (car l))
+           (symbol? (caar l))
+           (symbol-alist? (cdr l)))))
+
+;;; check the various syntactic forms
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+(test-assert (symbol-alist?
+              (car (on-test-runner
+                    (lambda ()
+                      (test-assert #t))
+                    (lambda (r)
+                      (test-result-alist r))))))
+
+;;; check to make sure the required properties are returned
+
+(test-equal '((result-kind . pass))
+	    (prop-runner
+             '(result-kind)
+             (lambda ()
+               (test-assert #t)))
+	    )
+
+(test-equal 
+            '((result-kind . fail)
+              (expected-value . 2)
+              (actual-value . 3))
+	    (prop-runner
+             '(result-kind expected-value actual-value)
+             (lambda ()
+               (test-equal 2 (+ 1 2)))))
+
+(test-end "9.1. test-result-alist")
+
+(test-begin "9.2. test-result-ref")
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert #t))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-equal '(fail pass)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-ref r 'result-kind))))
+
+(test-end "9.2. test-result-ref")
+
+(test-begin "9.3. test-result-set!")
+
+(test-equal '(100 100)
+	    (on-test-runner
+             (lambda ()
+               (test-assert (= 1 2))
+               (test-assert (= 1 1)))
+             (lambda (r)
+               (test-result-set! r 'foo 100)
+               (test-result-ref r 'foo))))
+
+(test-end "9.3. test-result-set!")
+
+(test-end "9. Test Result Properties")
+
+;;;
+;;;
+;;;
+
+#|  Time to stop having fun...
+
+(test-begin "9. For fun, some meta-test errors")
+
+(test-equal
+ "9.1. Really PASSes, but test like it should FAIL"
+ '(() ("b") () () ())
+ (triv-runner
+  (lambda ()
+    (test-assert "b" #t))))
+
+(test-expect-fail "9.2. Expect to FAIL and do so")
+(test-expect-fail "9.3. Expect to FAIL but PASS")
+(test-skip "9.4. SKIP this one")
+
+(test-assert "9.2. Expect to FAIL and do so" #f)
+(test-assert "9.3. Expect to FAIL but PASS" #t)
+(test-assert "9.4. SKIP this one" #t)
+
+(test-end)
+ |#
+
+(test-end "SRFI 64 - Meta-Test Suite")
+
+;;;
diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test
new file mode 100644
index 0000000..190d6b2
--- /dev/null
+++ b/test-suite/tests/srfi-64.test
@@ -0,0 +1,45 @@
+;;;; srfi-64.test --- Test suite for SRFI-64.  -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-64)
+  #:use-module ((test-suite lib) #:select (report))
+  #:use-module (srfi srfi-64))
+
+(define (guile-test-runner)
+  (let ((runner (test-runner-null)))
+    (test-runner-on-test-end! runner
+      (lambda (runner)
+        (let* ((result-alist (test-result-alist runner))
+               (result-kind (assq-ref result-alist 'result-kind))
+               (test-name (list (assq-ref result-alist 'test-name))))
+          (case result-kind
+            ((pass)  (report 'pass     test-name))
+            ((xpass) (report 'upass    test-name))
+            ((skip)  (report 'untested test-name))
+            ((fail xfail)
+             (apply report result-kind test-name result-alist))
+            (else #t)))))
+    runner))
+
+(test-with-runner
+ (guile-test-runner)
+ (primitive-load-path "tests/srfi-64-test.scm"))
+
+;;; Local Variables:
+;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1)
+;;; End:
-- 
1.7.5.4