aatree and linked-listHEADmaster

7 files changed, 1577 insertions, 4 deletions

diff --git a/README.rst b/README.rst
index 77ce6bc..29abc93 100644
--- a/README.rst
+++ b/README.rst
@@ -49,3 +49,13 @@ Differences from R7RS
 * Namespace names are identifers, not lists.
 * Namespaces are Scheme objects.
 * To import outside of namespaces, use IMPORT-FROM-NAMSPACE, not IMPORT.
+
+--------
+Examples
+--------
+
+* ``srfi/srfi-1.scm`` is the reference implementation of SRFI-1 wrapped in
+  a namespace.
+* ``examples/aatree.scm`` is an imperative binary tree implementation.
+  ``examples/test-aatree.scm`` uses SRFI-64 to run some tests on the
+  implementation. Requires SRFI-9 and SRFI-11 (``let-values``).
diff --git a/define-namespace-5.scm b/define-namespace-5.scm
index 0a9211c..bc1c6c9 100644
--- a/define-namespace-5.scm
+++ b/define-namespace-5.scm
@@ -85,7 +85,3 @@
   (syntax-rules ()
     ((import-from-namespace body ...)
      (%import-from-namespace '() body ...))))
-
-(import-from-namespace (only srfi-1 fold))
-(fold (lambda (elem acc) (+ elem acc)) 0'(1 2 3 4 5))
-
diff --git a/examples/aatree.scm b/examples/aatree.scm
new file mode 100644
index 0000000..918782c
--- /dev/null
+++ b/examples/aatree.scm
@@ -0,0 +1,232 @@
+;;;; Copyright (c) 2024, Peter McGoron
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1) Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2) Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer
+;;;;    in the documentation and/or other materials provided with the
+;;;;    distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;;;; POSSIBILITY OF SUCH DAMAGE.
+;;;; 
+;;;; This implements functional balanced binary search trees (AA Trees).
+;;;; 
+;;;; (NEW <=>) makes a new AA Tree root. 
+;;;; (<=> KEY1 KEY2) must return one of the symbols in '(< = >), which
+;;;; denote that KEY1 is less than, equivalent to, or greater than KEY2.
+;;;; 
+;;;; (SEARCH TREE KEY) searches the tree for the first node equivalent
+;;;; to KEY. If successful, it returns (VALUES 'FOUND KEY VAL). Otherwise
+;;;; it returns (VALUES 'NOT-FOUND '() '()).
+;;;; 
+;;;; (INSERT TREE KEY VAL) inserts KEY into TREE with value VAL. If
+;;;; a key equivalent to KEY is already in TREE, the old key is replaced with
+;;;; KEY and the old value is replaced with VAL, and the function returns
+;;;; (VALUES 'FOUND OLDKEY OLDVAL). If the value is not found, then
+;;;; the function returns (VALUES 'NOT-FOUND OLDKEY OLDVAL).
+;;;; 
+;;;; (DELETE TREE KEY) deletes the node equivalent to KEY, if it exists.
+;;;; It returns 
+
+(define-namespace aatree
+  (begin
+    (define-record-type :aatree-node
+      (new-node key value left right level)
+      node?
+      (key get-key key-set!)
+      (value get-value value-set!)
+      (left get-left left-set!)
+      (right get-right right-set!)
+      (level get-level-raw level-set!))
+    (define-record-type :aatree
+      (%aatree <=> root)
+      aatree?
+      (<=> get-<=>)
+      (root get-root set-root!))
+    (define leaf '())
+    (define (new <=>) (%aatree <=> leaf))
+    (define leaf? null?)
+    (define (get-level r)
+      (if (leaf? r)
+          0
+          (get-level-raw r)))
+    ; Option-like accessors
+    (define (maybe-right t)
+      (if (null? t)
+          leaf
+          (get-right t)))
+    (define (maybe-left t)
+      (if (null? t)
+          leaf
+          (get-left t)))
+    ; right rotation
+    ;        a        b
+    ;       / \      / \
+    ;      b   c -> d   a
+    ;     / \          / \
+    ;    d   e        e   c
+    (define (skew A)
+      (let* ((B (maybe-left A))
+             (E (maybe-right B)))
+        (if (and (not (leaf? A))
+                 (eq? (get-level B)
+                      (get-level A)))
+            (begin
+              (right-set! B A)
+              (left-set! A E)
+              B)
+            A)))
+    ; left rotation
+    ;     a            c
+    ;    / \          / \
+    ;   b   c   ->   a   e
+    ;      / \      / \
+    ;     d   e    b   d
+    ;   
+    (define (split A)
+      (let* ((C (maybe-right A))
+             (E (maybe-right C))
+             (D (maybe-left C)))
+        (if (and (not (leaf? A))
+                 (not (leaf? C))
+                 (eq? (get-level E)
+                      (get-level A)))
+            (begin
+              (left-set! C A)
+              (right-set! A D)
+              (level-set! C (+ (get-level C) 1))
+              C)
+            A)))
+    (define (search* <=> tree key)
+      (if (leaf? tree)
+          (values 'not-found '() '())
+          (let ((nodekey (get-key tree)))
+            (case (<=> key nodekey)
+              ((<) (search* <=> (get-left tree) key))
+              ((>) (search* <=> (get-right tree) key))
+              ((=) (values 'found nodekey (get-value tree)))))))
+    (define (search tree key) (search* (get-<=> tree) (get-root tree) key))
+    (define (insert* <=> node key val)
+      (if (leaf? node)
+          (values (new-node key val '() '() 1) 'not-found '() '())
+          (case (<=> key (get-key node))
+            ((=) (let ((oldval (get-value node)))
+                   (value-set! node val)
+                   (values node 'found (get-key node) oldval)))
+            ((<) (let-values (((newnode . rest)
+                               (insert* <=> (get-left node) key val)))
+                   (left-set! node newnode)
+                   (apply values (cons (split (skew node)) rest))))
+            ((>) (let-values (((newnode . rest)
+                               (insert* <=> (get-right node) key val)))
+                   (right-set! node newnode)
+                   (apply values (cons (split (skew node)) rest))))
+            (else (error "comparision must return <, =, or >")))))
+    (define (insert tree key val)
+      (let-values (((new-root . rest) (insert* (get-<=> tree) (get-root tree) key val)))
+        (set-root! tree new-root)
+        (apply values rest)))
+    (define (delete* <=> tree key)
+      (if (leaf? tree)
+          (values tree 'not-found '() '())
+          (let ((process (lambda (t)
+                           (if (leaf? t)
+                               t
+                               (let* ((level (get-level t))
+                                      (level-l (get-level (get-left t)))
+                                      (level-r (get-level (get-right t)))
+                                      (new-level (- level 1)))
+                                 (if (or (< level-l new-level)
+                                         (< level-r new-level))
+                                     (begin
+                                       (if (> level-r new-level)
+                                           (level-set! (get-right t)
+                                                       (min level-r new-level)))
+                                       (level-set! t new-level)
+                                       (set! t (skew t))
+                                       (right-set! t (skew (get-right t)))
+                                       (right-set! (get-right t)
+                                                   (skew (get-right (get-right t))))
+                                       (set! t (split t))
+                                       (right-set! t (split (get-right t)))))
+                                 t)))))
+            (case (<=> key (get-key tree))
+              ((<) (let-values (((newnode . rest)
+                                 (delete* <=> (get-left tree) key)))
+                     (left-set! tree newnode)
+                     (apply values (cons (process tree) rest))))
+              ((>) (let-values (((newnode . rest)
+                                 (delete* <=> (get-right tree) key)))
+                     (right-set! tree newnode)
+                     (apply values (cons (process tree) rest))))
+              ((=) (letrec
+                       ((del-min (lambda (t)
+                                   (if (leaf? (get-left t))
+                                       (values (get-right t) 'found (get-key t)
+                                               (get-value t))
+                                       (let-values (((newnode . rest)
+                                                     (del-min (get-left t))))
+                                         (if (leaf? (get-right t))
+                                             (error "imbalanced tree"))
+                                         (left-set! t newnode)
+                                         (apply values
+                                                (cons (process t) rest)))))))
+                     (if (leaf? (get-right tree))
+                         (if (not (leaf? (get-left tree)))
+                             (error "imbalanced tree")
+                             (values '() 'found (get-key tree) (get-value tree)))
+                         (let-values (((newnode status key value)
+                                       (del-min (get-right tree)))
+                                      ((oldvalue) (get-value tree))
+                                      ((oldkey) (get-key tree)))
+                           (key-set! tree key)
+                           (value-set! tree value)
+                           (right-set! tree newnode)
+                           (values (process tree) status oldkey oldvalue)))))))))
+    (define (delete tree key)
+      (let-values (((new-root . rest) (delete* (get-<=> tree)
+                                               (get-root tree)
+                                               key)))
+        (set-root! tree new-root)
+        (apply values rest)))
+    (define (aatree->alist* node alist)
+      (if (leaf? node)
+          alist
+          (let ((alist-right (aatree->alist* (get-right node) alist)))
+            (aatree->alist* (get-left node)
+                            (cons (cons (get-key node)
+                                        (get-value node))
+                                  alist-right)))))
+    (define (aatree->alist tree) (aatree->alist* (get-root tree) '()))
+    (define (alist->aatree* node <=> alist)
+      (if (null? alist)
+          node
+          (let ((pair (car alist)))
+            (let-values (((node . _)
+                          (insert node <=>
+                                  (car pair)
+                                  (cdr pair))))
+              (alist->aatree* node (cdr alist) <=>)))))
+    (define (alist->aatree tree)
+      (alist->aatree* (get-root tree) (get-<=> tree) '())))
+  (export
+   aatree?
+   new
+   aatree->alist alist->aatree
+   search insert delete))
+
diff --git a/examples/linked-list.scm b/examples/linked-list.scm
new file mode 100644
index 0000000..821d0b6
--- /dev/null
+++ b/examples/linked-list.scm
@@ -0,0 +1,27 @@
+(define-namespace linked-list
+  (define-record-type linked-list
+    (linked-list head tail)
+    linked-list?
+    (head get-head set-head!)
+    (tail get-tail set-tail!))
+  (define (new) (linked-list '() '()))
+  (define (empty? lst) (null? (get-head lst)))
+  (define (linked-list->list lst) (get-head lst))
+  (define (push-first lst val)
+    (let ((container (list val)))
+      (set-head! lst container)
+      (set-tail! list container)))
+  (define (push-head lst val)
+    (if (empty? lst)
+        (push-first lst val)
+        (set-head! lst (cons val (get-head lst)))))
+  (define (push-tail lst val)
+    (if (empty? lst)
+        (push-first lst val)
+        (let ((container (list val)))
+          (set-cdr! (get-tail lst) container)
+          (set-tail! lst container))))
+  (export new empty?
+          push-head push-tail
+          linked-list->list))
+
diff --git a/examples/test-aatree.scm b/examples/test-aatree.scm
new file mode 100644
index 0000000..903534b
--- /dev/null
+++ b/examples/test-aatree.scm
@@ -0,0 +1,188 @@
+;;;; Copyright (c) 2024, Peter McGoron
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1) Redistributions of source code must retain the above copyright
+;;;;    notice, this list of conditions and the following disclaimer.
+;;;; 2) Redistributions in binary form must reproduce the above copyright
+;;;;    notice, this list of conditions and the following disclaimer
+;;;;    in the documentation and/or other materials provided with the
+;;;;    distribution.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+;;;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+;;;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+;;;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+;;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+;;;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+;;;; POSSIBILITY OF SUCH DAMAGE.
+
+(load "../srfi/srfi-64.scm")
+(load "../define-namespace-5.scm")
+(load "aatree.scm")
+
+(define (string<=> x y)
+  (if (string<? x y)
+      '<
+      (if (string=? x y)
+          '=
+          '>)))
+
+(import-from-namespace
+ (only aatree aatree? aatree->alist)
+ (rename aatree
+         (new aatree/new)
+         (search aatree/search)
+         (insert aatree/insert)
+         (delete aatree/delete)))
+
+(test-begin "AATree")
+
+(test-begin "insert one")
+(define tree (aatree/new string<=>))
+(let-values (((status key value)
+              (aatree/insert tree "a" 1)))
+  (test-equal "insert status" 'not-found status)
+  (let-values (((status key value)
+                (aatree/search tree "a")))
+    (test-equal "search status" 'found status)
+    (test-equal "search key" "a" key)
+    (test-equal "search value" 1 value)))
+(test-end "insert one")
+
+
+(test-begin "insert many in order")
+(define inspairs
+  '(("a" . 1) ("b" . 2) ("c" . 3) ("d" . 4) ("e" . 5) ("f" . 6)
+            ("g" . 7) ("h" . 8) ("i" . 9) ("j" . 10) ("k" . 11) ("l" . 12)
+            ("m" . 13) ("n" . 14) ("o" . 15) ("p" . 16) ("q" . 17) ("r" . 18)
+            ("s" . 19) ("t" . 20) ("u" . 21) ("v" . 22) ("w" . 23) ("x" . 24)
+            ("y" . 25) ("z" . 26)))
+
+(define (fold-collect f start processed to-process)
+  (if (null? to-process)
+      start
+      (let ((new-elem (car to-process)))
+        (fold-collect f (f start new-elem processed)
+                      (cons new-elem processed)
+                      (cdr to-process)))))
+
+(define (iter f l)
+  (if (pair? l)
+      (begin
+        (f (car l))
+        (iter f (cdr l)))))
+
+(define (test-insert node pair searchlist)
+  (let-values (((status key value)
+                (aatree/insert node (car pair) (cdr pair))))
+    (test-equal "insert" 'not-found status)
+    (iter (lambda (pair)
+            (let ((key (car pair))
+                  (val (cdr pair)))
+              (let-values (((status retkey retval)
+                            (aatree/search node key)))
+                (test-equal "search status" 'found status)
+                (test-equal "search key" key retkey)
+                (test-equal "search value" val retval))))
+          searchlist)
+    node))
+
+
+(define inserted-in-order
+  (fold-collect test-insert (aatree/new string<=>) '() inspairs))
+(test-end "insert many in order")
+
+(display "a\n")
+;; Not possible to implement good randomin strictly portable R5RS scheme,
+;; Shuffled using "shuf"
+
+(test-begin "insert shuffled")
+(define shuffled-list
+  '(("k" . 11)
+    ("p" . 16)
+    ("r" . 18)
+    ("w" . 23)
+    ("x" . 24)
+    ("t" . 20)
+    ("f" . 6)
+    ("z" . 26)
+    ("h" . 8)
+    ("a" . 1)
+    ("s" . 19)
+    ("e" . 5)
+    ("d" . 4)
+    ("y" . 25)
+    ("c" . 3)
+    ("j" . 10)
+    ("v" . 22)
+    ("g" . 7)
+    ("o" . 15)
+    ("q" . 17)
+    ("m" . 13)
+    ("u" . 21)
+    ("l" . 12)
+    ("b" . 2)
+    ("n" . 14)
+    ("i" . 9)))
+(fold-collect test-insert (aatree/new string<=>) '() shuffled-list)
+(test-end "insert shuffled")
+
+(test-begin "delete one")
+
+(define tree (aatree/new string<=>))
+(let-values (((status key value)
+              (aatree/insert tree "a" 1)))
+  (test-equal "insert status" 'not-found status)
+  (let-values (((status retkey retval)
+                (aatree/search tree "a")))
+    (test-equal "search 1 status" 'found status)
+    (test-equal "search 1 key" "a" retkey)
+    (test-equal "search 1 value" 1 retval)
+    (let-values (((status retkey retval)
+                  (aatree/delete tree "a")))
+      (test-equal "delete status" 'found status)
+      (test-equal "delete key" "a" retkey)
+      (test-equal "delete value" 1 retval)
+      (let-values (((status . _)
+                    (aatree/search tree "a")))
+        (test-equal "search 2 status" status 'not-found)))))
+(test-end "delete one")
+
+(define (test-delete tree deleted to-delete)
+  (if (pair? to-delete)
+      (let ((pair (car to-delete)))
+        (let-values (((status retkey retval)
+                      (aatree/delete tree (car pair))))
+          (test-equal "delete status" 'found status)
+          (test-equal "delete key" (car pair) retkey)
+          (test-equal "delete value" (cdr pair) retval)
+          (iter (lambda (pair)
+                  (let ((key (car pair)))
+                    (let-values (((status . _)
+                                  (aatree/search tree key)))
+                      (test-equal "deleted search" 'not-found status))))
+                (cons pair deleted))
+          (iter (lambda (pair)
+                  (let ((key (car pair))
+                        (val (cdr pair)))
+                    (let-values (((status retkey retval)
+                                  (aatree/search tree key)))
+                      (test-equal "to-delete search" 'found status)
+                      (test-equal "to-delete search value" val retval)
+                      (test-equal "to-delete search key" key retkey))))
+                (cdr to-delete))
+          (test-delete tree (cons pair deleted) (cdr to-delete))))))
+
+(test-begin "insert and shuffled delete")
+(test-delete inserted-in-order '() shuffled-list)
+(test-end "insert and shuffled delete")
+
+(test-end "AATree")
diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm
new file mode 100644
index 0000000..584875d
--- /dev/null
+++ b/srfi/srfi-11.scm
@@ -0,0 +1,34 @@
+(define-syntax let-values
+  (syntax-rules ()
+    ((let-values (?binding ...) ?body0 ?body1 ...)
+     (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
+    
+    ((let-values "bind" () ?tmps ?body)
+     (let ?tmps ?body))
+    
+    ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
+     (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
+    
+    ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
+     (call-with-values 
+       (lambda () ?e0)
+       (lambda ?args
+         (let-values "bind" ?bindings ?tmps ?body))))
+    
+    ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
+     (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
+    
+    ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
+     (call-with-values
+       (lambda () ?e0)
+       (lambda (?arg ... . x)
+         (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
+
+(define-syntax let*-values
+  (syntax-rules ()
+    ((let*-values () ?body0 ?body1 ...)
+     (begin ?body0 ?body1 ...))
+
+    ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
+     (let-values (?binding0)
+       (let*-values (?binding1 ...) ?body0 ?body1 ...)))))
diff --git a/srfi/srfi-64.scm b/srfi/srfi-64.scm
new file mode 100644
index 0000000..6b27978
--- /dev/null
+++ b/srfi/srfi-64.scm
@@ -0,0 +1,1086 @@
+;; 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) ; NOTE: chicken already has 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)
+  (import (scheme base)
+          (only (kawa base) try-catch))
+  (provide 'srfi-64)
+  (provide 'testing)
+  (require 'srfi-35))
+ (gauche
+  (define-module srfi-64)
+  (select-module srfi-64))
+ (else
+  ))
+
+(cond-expand
+ (kawa
+  ;; Kawa's default top-level environment has test-begin built in,
+  ;; as a magic macro that imports this library (without test-begin).
+  ;; This puts test-begin but only test-begin in the default environment,
+  ;; which makes normal test suites loadable without non-portable commands.
+  ;; Therefore we need to export %test-begin, which performs the
+  ;; functionality of test-begin without the magic import.
+  (define-syntax %test-export
+    (syntax-rules ()
+      ((%test-export test-begin . other-names)
+       (module-export %test-begin test-begin . other-names)))))
+ (gauche
+  (define-syntax %test-export export))
+ (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 tname alloc runner? (name index getter setter) ...)
+       (define-record-type tname
+	 (alloc)
+	 runner?
+	 (name getter setter) ...)))))
+ (else
+  (define %test-runner-cookie (list "test-runner"))
+  (define-syntax %test-record-define
+    (syntax-rules ()
+      ((%test-record-define tname 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
+ %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.
+(cond-expand
+ (kawa
+  (define (test-runner-get) ::test-runner
+    (let ((r (test-runner-current)))
+      (if (not r)
+          (error "test-runner not initialized - test-begin missing?"))
+      r)))
+ (else
+  (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)))))
+(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-name (if (string? test-log-to-file) test-log-to-file
+                                 (string-append suite-name ".log")))
+                   ;; Replace "bad" characters in log file name with #\_
+                   (fix-invalid-char
+                    (lambda (ch)
+                      (if (or (char-alphabetic? ch)
+                              (char-numeric? ch)
+                              (char=? ch #\space) ;; FIX from SRFI
+                              (char=? ch #\-)
+                              (char=? ch #\+)
+                              (char=? ch #\_)
+                              (char=? ch #\.)
+                              (char=? ch #\,))
+                          ch
+                          #\_)))
+                   (log-file-name
+                    (cond-expand (r7rs
+                                  (string-map fix-invalid-char log-name))
+                                 (else
+                                  (let ((t (string-copy log-name))
+                                        (tlen (string-length log-name)))
+                                    (do ((i 0 (+ i 1))) ((>= i tlen) t)
+                                      (string-set! t i (fix-invalid-char
+                                                        (string-ref t i))))))))
+		   (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 (or (test-runner-current)
+                  (begin
+                   (test-runner-current (test-runner-create))
+                   (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-actual-value! runner value)
+  (test-result-set! runner 'actual-value value))
+
+(define (test-result-expected-value! runner value)
+  (test-result-set! runner 'expected-value value))
+
+(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-expected-value! r exp)
+			 (let ((res (%test-evaluate-with-catch expr)))
+			   (test-result-actual-value! r 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-actual-value! r 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-actual-value! r 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-actual-value! r 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-actual-value! r 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-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)))))))
+
+(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))))))
+
+;;; 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)))
+         (gauche (eval form ((with-module gauche.internal vm-current-module))))
+	 (else (eval form)))
+	(cond-expand
+	 (srfi-23 (error "(not at eof)"))
+	 (else "error")))))
+