reorganize tests, use dead-simple test harness

7 files changed, 998 insertions, 829 deletions

diff --git a/README.md b/README.md
index 4afab6d..b098a41 100644
--- a/README.md
+++ b/README.md
@@ -37,7 +37,8 @@ or explicitly using `seq`. This allows for the call-by-value semantics
 of Scheme to be turned into call-by-need semantics without any syntactic
 cruft.
 
-HaScheme should run in any implemention of the R⁷RS.
+HaScheme should run in any implemention of the R⁷RS that supports the
+[SRFI 259][SRFI-259]. It does not use `(scheme lazy)`.
 
 Why use this?
 
@@ -52,6 +53,8 @@ See also [Lazy Racket][LazyRacket].
 
 HaScheme is licensed under the 0BSD license.
 
+HaScheme is tested to work in CHICKEN 6.0.0 latest master.
+
 ## Restrictions and Implementation Notes
 
 1. No `call/cc`. [Explanation](#multiple-values-and-continuations)
@@ -232,7 +235,8 @@ the code should look natural.
 
 Instead, this library uses [SRFI 259][SRFI-259] tagged procedures to wrap
 promises. This allows for arbitrary higher-order procedures expressed
-in a natural way.
+in a natural way. The R7RS `delay`/`delay-force`/`force` expressions
+are re-implemented using the tagged procedures.
 
 Each `lambda` creates a procedure object that can be called with an
 arbitrary number of arguments to create another procedure. Procedure
diff --git a/hascheme.egg b/hascheme.egg
index 710fe95..3c35232 100644
--- a/hascheme.egg
+++ b/hascheme.egg
@@ -4,7 +4,6 @@
  (category lang-exts)
  (license "BSD 0-clause")
  (dependencies r7rs srfi-259)
- (test-dependencies test)
  (components (extension hascheme.base
                (source "lib/hascheme/base.sld")
                (source-dependencies "lib/hascheme/base.scm")
diff --git a/lib/tests/hascheme/base.scm b/lib/tests/hascheme/base.scm
new file mode 100644
index 0000000..738879a
--- /dev/null
+++ b/lib/tests/hascheme/base.scm
@@ -0,0 +1,853 @@
+(define-syntax h:set!
+  (syntax-rules ()
+    ((_ name value) (delay (set! name value)))))
+
+(define (test-base)
+  (test-group "SRFI-45" (test-srfi-45))
+  (test-group "preliminaries" (test-preliminaries))
+  (test-group "lambda" (test-lambda))
+  (test-group "if" (test-if))
+  (test-group "cond" (test-cond))
+  (test-group "do" (test-do))
+  (test-group "case" (test-case))
+  (test-group "and" (test-and))
+  (test-group "or" (test-or))
+  (test-group "when and unless" (test-when-and-unless))
+  (test-group "record types" (test-record-types))
+  (test-group "apply" (test-apply))
+  (test-group "floor/" (test-converted-number-function h:floor/
+                                                       -5 2
+                                                       '(-3 1)))
+  (test-group "truncate/" (test-converted-number-function h:truncate/
+                                                          -5 2
+                                                          '(-2 -1)))
+  (test-group "exact-integer-sqrt" (test-exact-integer-sqrt))
+  (test-group "equal?" (my-test-equal?))
+  (test-group "wrappers from strict" (test-wrappers-from-strict))
+  (test-group "constructors" (test-constructors))
+  (test-group "binary wrappers" (test-binary-wrappers))
+  (test-group "vector-map" (test-vector-map))
+  (test-group "list?" (test-list?))
+  (test-group "make-list" (test-make-list))
+  (test-group "length" (test-length))
+  (test-group "append" (test-append))
+  (test-group "reverse" (test-reverse))
+  (test-group "list-tail" (test-list-tail))
+  (test-group "list-ref" (test-list-ref))
+  (test-group "member" (test-member))
+  (test-group "assoc" (test-assoc))
+  (test-group "map" (test-map))
+  (test-group "list->string" (test-list->string))
+  (test-group "make-vector" (test-make-vector))
+  (test-group "list->vector" (test-list->vector))
+  (test-group "list-copy" (test-list-copy))
+  (test-group "other binding constructors" (test-other-binding-constructs)))
+
+(define (test-srfi-45)
+  #| These tests are taken from SRFI-45.
+
+Copyright (C) André van Tonder (2003). All Rights Reserved.
+
+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. |#
+  (test-group "memo 1"
+    (let* ((effect 0)
+           (expr (delay (begin (set! effect (+ effect 1)) 10))))
+      (test-equal 0 effect)
+      (test-equal 10 (force expr))
+      (test-equal 1 effect)
+      (test-equal 10 (force expr))
+      (test-equal 1 effect)))
+  (test-group "memo 2"
+    (let* ((effect 0)
+           (expr (delay (begin (set! effect (+ effect 1)) 2))))
+      (test-equal 4 (+ (force expr) (force expr)))
+      (test-equal 1 effect)))
+  (test-group "memo 3"
+    (let* ((effect 0)
+           (r (delay (begin (set! effect (+ effect 1)) 1)))
+           (s (delay-force r))
+           (t (delay-force s)))
+      (test-equal 1 (force s))
+      (test-equal 1 (force t))
+      (test-equal 1 effect)))
+  (test-group "memo 4"
+    (letrec* ((effect 0)
+              (stream-drop (lambda (s index)
+                             (delay-force
+                              (if (zero? index)
+                                  s
+                                  (stream-drop (cdr (force s))
+                                               (- index 1))))))
+              (ones (lambda () (delay (begin
+                                        (set! effect (+ effect 1))
+                                        (cons 1 (ones))))))
+              (s (ones)))
+             (test-equal 0 effect)
+             (test-equal 1 (car (force (stream-drop s 4))))
+             (test-equal "effect, 1" 5 effect)
+             (test-equal 1 (car (force (stream-drop s 4))))
+             (test-equal "effect, 2" 5 effect)
+             (test-equal 1 (car (force (stream-drop s 4))))
+             (test-equal "effect, 3" 5 effect)))
+  (test-group "reenter 1"
+    (letrec* ((count 0)
+              (p (delay (begin (set! count (+ count 1))
+                               (if (> count x)
+                                   count
+                                   (force p)))))
+              (x 5))
+             (test-equal 6 (force p))
+             (set! x 10)
+             (test-equal 6 (force p))))
+  (test-group "reenter 2"
+    (letrec* ((first? #t)
+              (f (delay (if first?
+                            (begin
+                              (set! first? #f)
+                              (force f))
+                            'second))))
+             (test-equal 'second (force f))))
+  (test-group "reenter 3"
+    (letrec* ((count 5)
+              (p (delay (if (<= count 0)
+                            count
+                            (begin (set! count (- count 1))
+                                   (force p)
+                                   (set! count (+ count 2))
+                                   count)))))
+             (test-equal 5 count)
+             (test-equal 0 (force p))
+             (test-equal 10 count))))
+
+(define (test-preliminaries)
+  (test-assert "forcing a value is valid"
+               (let ((ok (lambda (x) (equal? (force x) x))))
+                 (and (ok #t)
+                      (ok #\x)
+                      (ok 0)
+                      (ok "a")
+                      (ok 'a)
+                      (ok '(1 2 3))
+                      (ok '#(1 2 3))
+                      (ok (list 1 2 3))
+                      (ok (vector 1 2 3))
+                      (ok '())
+                      (ok #u8(1 2 3))
+                      (ok (lambda (x) x)))))
+  (let* ((x 0)
+         (expr (h:set! x (+ x 1))))
+    (test-assert "set! returns a promise"
+                 (promise? expr))
+    (test-equal "set! has not run yet"
+                0
+                x)
+    (force expr)
+    (test-equal "set! is effectful"
+                1
+                x)
+    (force expr)
+    (test-equal "set! does not run more than once"
+                1
+                x)))
+
+(define (test-lambda)
+  (test-assert "lambda returns a procedure"
+               (procedure? (h:lambda (x) x)))
+  (test-assert "application of lambda returns a promise"
+               (promise? ((h:lambda (x) x) 5)))
+  (test-equal "forcing a promise returns the value"
+              5
+              (force ((h:lambda (x) x) 5)))
+  (let ()
+    (h:define (id x) x)
+    (test-assert "internal define is a procedure"
+                 (procedure? id)))
+  (let* ((effect 'not-run)
+         (expr (h:lambda (x y) x)))
+    (force (expr (h:set! effect 'run) (h:set! effect 'error)))
+    (test-equal "lambda is not non-strict"
+                'run
+                effect)))
+
+(define (test-if)
+  (test-assert "if returns a promise"
+               (promise? (h:if #t #t #f)))
+  (test-equal "forcing if runs it"
+              'true
+              (force (h:if #t 'true 'false)))
+  (let* ((effect 'not-run)
+         (test-effect 'not-run)
+         (expr (h:if (h:seq (h:set! test-effect 'run)
+                            #f)
+                     (h:set! effect 'true)
+                     (h:set! effect 'false))))
+    (test-equal "creation of if does not run anything"
+                'not-run
+                effect)
+    (test-equal "creation of if does not run anything, 2"
+                'not-run
+                test-effect)
+    (force expr)
+    (test-equal "if is eager in the predicate"
+                'run
+                test-effect)
+    (test-equal "forcing if forces the path"
+                'false
+                effect)))
+
+(define (test-let)
+  (test-equal "let works as normal"
+              5
+              (h:let ((x 5))
+                     x))
+  (let ((loop (h:let loop ((x 0))
+                     (if (< x 10)
+                         (loop (+ x 1))
+                         x))))
+    (test-assert "named let returns a promise"
+                 (promise? loop))
+    (test-equal "forcing named let runs the promise"
+                10
+                (force loop))))
+
+(define (test-do)
+  (let ((loop (h:do ((l '(a b c) (h:cdr l))
+                     (acc 0 (h:+ acc 1)))
+                    ((h:null? l) acc))))
+    (test-assert "do returns a promise"
+                 (promise? loop))
+    (test-equal "do runs when forced"
+                3
+                (force loop)))
+  (let* ((effect 0)
+         (loop (h:do ((l '(a b c) (h:cdr l)))
+                     ((h:null? l))
+                     (h:set! effect (+ effect 1)))))
+    (test-equal "do has not run yet"
+                0
+                effect)
+    (force loop)
+    (test-equal "do runs its body for effects, fresh each time"
+                3
+                effect)))
+
+(define (test-seq)
+  (test-assert "seq returns a promise"
+               (promise? (h:seq #t #t #t)))
+  (test-equal "seq returns its last argument"
+              5
+              (force (h:seq 0 1 2 3 4 5)))
+  (let ((effect1 0)
+        (effect2 0))
+    (test-equal "force has not run yet"
+                '(0 0)
+                (list effect1 effect2))
+    (force (h:seq (h:set! effect1 1) (h:set! effect2 2)))
+    (test-equal "seq forces all arguments"
+                '(1 2)
+                (list effect1 effect2))))
+
+(define (test-cond)
+  ;; TODO: Test on non-CHICKEN systems.
+  (cond-expand
+   (chicken
+    (test-assert "cond returns a promise"
+                 (promise? (h:cond (#t #t) (else #f))))
+    (let ((x 1))
+      (test-equal "cond works like cond"
+                  'true
+                  (force (h:cond
+                          ((h:= x 0) 0)
+                          ((h:= x 1) 'true)
+                          (else 'false)))))
+    (let* ((effect 'not-run)
+           (expr (h:cond
+                  ((h:seq (h:set! effect 'run-once)
+                          #t) #t)
+                  (else (h:set! effect 'false) #f))))
+      (test-equal "cond has not run yet"
+                  'not-run
+                  effect)
+      (test-assert "cond works like cond, 2"
+                   (force expr))
+      (test-equal "cond has made an effect"
+                  'run-once
+                  effect)))))
+
+(define (test-case)
+  (cond-expand
+   (chicken
+    (let ((expr (h:case 5
+                        ((1 2 3 4) 'a)
+                        ((5 6 7 8) 'b)
+                        (else 'c))))
+      (test-assert "case returns a promise"
+                   (promise? expr))
+      (test-equal "case runs as normal"
+                  'b
+                  (force expr))))))
+
+(define (test-and)
+  (let* ((effect 0)
+         (expr (h:and 1 2 3 (h:seq (h:set! effect 1) #f)
+                      (h:seq (h:set! effect 2) #t))))
+    (test-assert "and returns a promise"
+                 (promise? expr))
+    (test-equal "and has not run yet"
+                0
+                effect)
+    (test-assert "and runs as normal for falses"
+                 (not (force expr)))
+    (test-equal "and is non-strict"
+                1
+                effect))
+  (test-equal "and runs as normal for truthy"
+              5
+              (force (h:and 1 2 3 4 5)))
+  (test-assert "and run as normal for the zero argument case"
+               (h:and)))
+
+(define (test-or)
+  (let* ((effect 0)
+         (expr (h:or #f #f #f (h:seq (h:set! effect 1) #t)
+                     (h:seq (h:set! effect 2) #f))))
+    (test-assert "or returns a promise"
+                 (promise? expr))
+    (test-equal "or has not run yet"
+                0
+                effect)
+    (test-assert "or runs as normal for truths"
+                 (force expr))
+    (test-equal "or is non-strict"
+                1
+                effect))
+  (test-assert "or runs as normal for falses"
+               (not (force (h:or #f #f))))
+  (test-assert "or runs as normal for the zero argument case"
+               (not (force (h:or)))))
+
+(define (test-when-and-unless)
+  (let* ((effect 0)
+         (expr1 (h:when #f (h:set! effect 1)))
+         (expr2 (h:unless #t (h:set! effect 2))))
+    (test-assert "when returns a promise"
+                 (promise? expr1))
+    (test-assert "unless returns a promise"
+                 (promise? expr2))
+    (test-equal "neither have run yet"
+                0
+                effect)
+    (force expr1)
+    (test-equal "when acts as normal for false cases"
+                0
+                effect)
+    (force expr2)
+    (test-equal "unless acts as normal for true cases"
+                0
+                effect))
+  (let* ((effect 0)
+         (expr1 (h:when (h:and) (h:set! effect 1)))
+         (expr2 (h:unless (h:or) (h:set! effect 2))))
+    (force expr1)
+    (test-equal "when acts as normal for true cases"
+                1
+                effect)
+    (force expr2)
+    (test-equal "unless acts as normal for false cases"
+                2
+                effect)))
+
+(define (test-record-types)
+  (h:define-record-type <test>
+                        (kons kar kdr kbr)
+                        kons?
+                        (kar kar)
+                        (kdr kdr)
+                        (kbr kbr))
+  (let* ((effect 0)
+         (expr (kons (h:seq (h:set! effect 1)
+                            10)
+                     (h:seq (h:set! effect 2)
+                            20)
+                     (h:seq (h:set! effect 3)
+                            30))))
+    (test-assert "constructor returns a promise"
+                 (promise? expr))
+    (test-assert "forcing returns a value that the predicate accepts"
+                 (force (kons? expr)))
+    (test-equal "constructor is not strict in any argument"
+                0
+                effect)
+    (test-equal "accessor 2"
+                20
+                (force (kdr expr)))
+    (test-equal "accessor is strict in its argument"
+                2
+                effect)
+    (test-equal "accessor 3"
+                30
+                (force (kbr expr)))
+    (test-equal "accessor 3 is strict in its argument"
+                3
+                effect)
+    (test-equal "accessor 1"
+                10
+                (force (kar expr)))
+    (test-equal "accessor 1 is strict in its argument"
+                1
+                effect)))
+
+(define (test-apply)
+  (let* ((effect 0)
+         (effect2 0)
+         (effect3 0)
+         (expr (h:apply (h:seq (h:set! effect 1) (h:lambda (x y) x))
+                        (h:seq (h:set! effect2 1) 1)
+                        (h:list (h:seq (h:set! effect3 1) 2)))))
+    (test-assert "apply returns a promise"
+                 (promise? expr))
+    (test-equal "apply has not run yet"
+                '(0 0 0)
+                (list effect effect2 effect3))
+    (test-equal "apply runs as expected"
+                1
+                (force expr))
+    (test-equal "apply is strict in its first argument"
+                1
+                effect)
+    (test-equal "apply is strict as its input function"
+                1
+                effect2)
+    (test-equal "apply is not strict where its input is not"
+                0
+                effect3)))
+
+(define (test-converted-number-function proc in1 in2 out)
+  (let* ((effect1 0)
+         (effect2 0)
+         (expr (proc (h:seq (h:set! effect1 2)
+                            in1)
+                     (h:seq (h:set! effect2 3)
+                            in2))))
+    (test-assert "returns a promise"
+                 (promise? expr))
+    (test-equal "not run yet"
+                '(0 0)
+                (list effect1 effect2))
+    (test-equal "returns correct values"
+                out
+                (recursive-force expr))
+    (test-equal "effects"
+                '(2 3)
+                (list effect1 effect2))))
+
+(define (test-exact-integer-sqrt)
+  (test-equal "works"
+              '(2 1)
+              (recursive-force (h:exact-integer-sqrt 5))))
+
+(define (test-wrappers-from-strict)
+  (test-assert "pair?"
+               (force (h:pair? (h:cons 1 2)))))
+
+(define (test-constructors)
+  (test-group "cons"
+    (let* ((effect1 0)
+           (effect2 0)
+           (expr (h:cons (h:seq (h:set! effect1 1) 1)
+                         (h:seq (h:set! effect2 1) 2))))
+      (force expr)
+      (test-equal "cons is not strict"
+                  '(0 0)
+                  (list effect1 effect2))
+      (test-equal "accessing car works"
+                  1
+                  (force (h:car expr)))
+      (test-equal "effects after car"
+                  '(1 0)
+                  (list effect1 effect2))
+      (test-equal "accessing cdr works"
+                  2
+                  (force (h:cdr expr)))
+      (test-equal "effects after cdr"
+                  '(1 1)
+                  (list effect1 effect2))
+      (test-equal "recursive force"
+                  '(1 . 2)
+                  (recursive-force expr)))))
+
+(define (test-binary-wrappers)
+  (let* ((effect1 0)
+         (effect2 0)
+         (effect3 0)
+         (effect4 0)
+         (expr (h:< (h:seq (h:set! effect1 1) 1)
+                    (h:seq (h:set! effect2 1) 2)
+                    (h:seq (h:set! effect3 1) 0)
+                    (h:seq (h:set! effect4 1) 10))))
+    (test-assert "< returns a promise"
+                 (promise? expr))
+    (test-equal "< has not run yet"
+                '(0 0 0 0)
+                (list effect1 effect2 effect3 effect4))
+    (test-assert "< works for the false case"
+                 (not (force expr)))
+    (test-equal "< is not necessarily strict"
+                '(1 1 1 0)
+                (list effect1 effect2 effect3 effect4))))
+
+(define (test-vector-map)
+  (let* ((effect1 0)
+         (effect2 0)
+         (expr (h:vector-map (h:lambda (x y) (h:+ x y))
+                             (h:seq (h:set! effect1 1)
+                                    (h:vector 1 2 3))
+                             (h:vector 4 5 6 (h:seq (h:set! effect2 1)
+                                                    7)))))
+    (test-assert "vector-map returns a promise"
+                 (promise? expr))
+    (test-assert "vector-map forced returns a vector"
+                 (vector? (force expr)))
+    (test-equal "vector-map is non-strict"
+                '(1 0)
+                (list effect1 effect2))
+    (test-equal "vector-map returns as expected"
+                '#(5 7 9)
+                (recursive-force expr))))
+
+(define (my-test-equal?)
+  (test-group "equal? on equal lists"
+    (let* ((effect1 0)
+           (effect2 0)
+           (effect3 0)
+           (effect4 0)
+           (expr (h:equal? (h:list (h:seq (h:set! effect1 1) 1)
+                                   (h:seq (h:set! effect2 1) 2))
+                           (h:list (h:seq (h:set! effect3 1) 1)
+                                   (h:seq (h:set! effect4 1) 2)))))
+      (test-assert "equal" (force expr))
+      (test-equal "equal? is strict on equal values"
+                  '(1 1 1 1)
+                  (list effect1 effect2 effect3 effect4))))
+  (test-group "equal? on unequal lists"
+    (let* ((effect1 0)
+           (effect2 0)
+           (effect3 0)
+           (expr (h:equal? (h:list (h:seq (h:set! effect1 1) 1))
+                           (h:list (h:seq (h:set! effect2 1) 1)
+                                   (h:seq (h:set! effect3 1) 2)))))
+      (test-assert "not equal" (not (force expr)))
+      (test-equal "equal? is not strict in all values"
+                  '(1 1 0)
+                  (list effect1 effect2 effect3))))
+  (test-group "equal? on equal vectors"
+    (let* ((effect1 0)
+           (effect2 0)
+           (effect3 0)
+           (effect4 0)
+           (expr (h:equal? (h:vector (h:seq (h:set! effect1 1) 1)
+                                     (h:seq (h:set! effect2 1) 2))
+                           (h:vector (h:seq (h:set! effect3 1) 1)
+                                     (h:seq (h:set! effect4 1) 2)))))
+      (test-assert "equal" (force expr))
+      (test-equal "equal? is strict on equal values"
+                  '(1 1 1 1)
+                  (list effect1 effect2 effect3 effect4))))
+  (test-group "equal? on unequal vectors"
+    (let* ((effect1 0)
+           (effect2 0)
+           (effect3 0)
+           (expr (h:equal? (h:vector (h:seq (h:set! effect1 1) 1))
+                           (h:vector (h:seq (h:set! effect2 1) 1)
+                                     (h:seq (h:set! effect3 1) 2)))))
+      (test-assert "not equal" (not (force expr)))
+      (test-equal "equal? is not strict in all values"
+                  '(0 0 0)
+                  (list effect1 effect2 effect3)))))
+
+(define (test-list?)
+  (let* ((effect1 0)
+         (effect2 0)
+         (expr (h:list? (h:cons (h:seq (h:set! effect1 1) 1)
+                                (h:seq (h:set! effect2 1)
+                                       (h:cons 2 '()))))))
+    (test-equal "expression has not run yet"
+                '(0 0)
+                (list effect1 effect2))
+    (test-assert "list? works"
+                 (force expr))
+    (test-equal "list? does not force the values of the list"
+                '(0 1)
+                (list effect1 effect2))))
+
+(define (test-make-list)
+  (let* ((effect 0)
+         (expr (h:make-list (h:seq (h:set! effect (+ effect 1)) 5) 10)))
+    (test-assert "expr makes a list"
+                 (force (h:list? expr)))
+    (test-equal "make-list is strict in its first argument"
+                1
+                effect)
+    (test-equal "first element"
+                10
+                (force (h:car expr)))
+    (test-equal "second element"
+                10
+                (force (h:cadr expr)))
+    (test-equal "recursive force"
+                '(10 10 10 10 10)
+                (recursive-force expr)))
+  (let* ((expr (h:make-list +inf.0 10)))
+    (test-equal "infinity is OK"
+                10
+                (force (h:cadr expr)))))
+
+(define (test-length)
+  (let* ((effect1 0)
+         (effect2 0)
+         (effect3 0)
+         (expr (h:length (h:list (h:seq (h:set! effect1 1) 1)
+                                 (h:seq (h:set! effect2 1) 2)
+                                 (h:seq (h:set! effect3 1) 3)))))
+    (test-equal "length works on lists"
+                3
+                (force expr))
+    (test-equal "length does not force values in the list"
+                '(0 0 0)
+                (list effect1 effect2 effect3))))
+
+(define (test-append)
+  (test-equal "zero argument case" '() (force (h:append)))
+  (test-group "single argument case"
+    (let* ((effect 0)
+           (expr (h:append (h:seq (h:set! effect 1) 1))))
+      (test-equal "returns its argument"
+                  1
+                  (force expr))))
+  (test-group "multiple lists"
+    (let* ((effect0 0)
+           (effect1 0)
+           (effect2 0)
+           (expr (h:append (h:seq (h:set! effect0 1)
+                                  (h:list (h:seq (h:set! effect1 1) 1)
+                                          2))
+                           (h:seq (h:set! effect2 1) '(3 4)))))
+      (force expr)
+      (test-equal "strict in all arguments except the last"
+                  '(1 0 0)
+                  (list effect0 effect1 effect2))
+      (test-equal "append works as expected"
+                  '(1 2 3 4)
+                  (recursive-force expr)))))
+
+(define (test-reverse)
+  (let* ((effect0 0)
+         (effect1 0)
+         (expr (h:reverse (h:seq (h:set! effect0 1)
+                                 (h:list (h:seq (h:set! effect1 1) 1)
+                                         2
+                                         3)))))
+    (force expr)
+    (test-equal "reverse is strict in the pairs, not the values"
+                '(1 0)
+                (list effect0 effect1))
+    (test-equal "reverse works as expected"
+                '(3 2 1)
+                (recursive-force expr))))
+
+(define (test-list-tail)
+  (let* ((effect0 0)
+         (effect1 0)
+         (effect2 0)
+         (expr (h:list-tail (h:seq (h:set! effect0 1)
+                                   (h:list (h:seq (h:set! effect1 1) 1)
+                                           2
+                                           3
+                                           4))
+                            (h:seq (h:set! effect2 1)
+                                   2))))
+    (force expr)
+    (test-equal "list-tail is strict in both arguments, pairs only"
+                '(1 0 1)
+                (list effect0 effect1 effect2))
+    (test-equal "list-tail works as expected"
+                '(3 4)
+                (recursive-force expr))
+    (test-equal "list-tail never evaluates discarded values"
+                0
+                effect1)))
+
+(define (test-list-ref)
+  (let* ((effect0 0)
+         (effect1 0)
+         (effect2 0)
+         (effect3 0)
+         (effect4 0)
+         (expr (h:list-ref (h:seq (h:set! effect0 1)
+                                  (h:list (h:seq (h:set! effect1 1) 1)
+                                          2
+                                          (h:seq (h:set! effect2 1) 3)
+                                          (h:seq (h:set! effect3 1) 4)))
+                           (h:seq (h:set! effect4 1) 2))))
+    (test-equal "evaluated to"
+                3
+                (force expr))
+    (test-equal "strictness of forcing the expression"
+                '(1 0 1 0 1)
+                (list effect0 effect1 effect2 effect3 effect4))))
+
+(define (test-member)
+  (let* ((effect 0)
+         (expr (h:member 10 (h:let loop ((x 0))
+                                   (h:seq (h:set! effect (force x))
+                                          (h:cons x (loop (h:+ x 1))))))))
+    (test-equal "member works as expected"
+                10
+                (force (h:car expr)))
+    (test-equal "side effects"
+                10
+                effect)))
+
+(define (test-assoc)
+  (let* ((effect 0)
+         (expr (h:assoc 10 (h:let loop ((x 0)
+                                        (y 2))
+                                  (h:seq (h:set! effect (force x))
+                                         (h:cons (h:cons x y)
+                                                 (loop (h:+ x 1)
+                                                       (h:* y 2))))))))
+    (test-equal "assoc works as expected"
+                '(10 . 2048)
+                (recursive-force expr))
+    (test-equal "side effects"
+                10
+                effect)))
+
+(define (test-map)
+  (let* ((expr (h:map h:+ '(1 2 3 4) '(10 20 30 40))))
+    (test-equal "works"
+                '(11 22 33 44)
+                (recursive-force expr)))
+  (let* ((h:add-n (h:lambda (n)
+                    (h:lambda (x)
+                      (h:+ n x))))
+         (expr (h:map (h:add-n 10) '(1 2 3 4))))
+    (test-equal "higher-order procedures work"
+                '(11 12 13 14)
+                (recursive-force expr))))
+
+(define (test-list->string)
+  (let* ((expr1 (h:list->string (h:list #\x #\y #\z)))
+         (expr2 (h:list->string '(#\x #\y #\z))))
+    (test-assert "works"
+                 (string=? (force expr1) (force expr2) "xyz"))))
+
+(define (test-make-vector)
+  (let* ((effect 0)
+         (expr (h:make-vector (h:seq (h:set! effect (+ effect 1)) 10) 0)))
+    (test-equal "works"
+                '#(0 0 0 0 0 0 0 0 0 0)
+                (recursive-force expr))
+    (test-equal "effects" 1 effect)))
+
+(define (test-list->vector)
+  (let* ((effect 0)
+         (expr1 (h:list->vector (h:list (h:seq (h:set! effect 1) 1)
+                                        2 3 4)))
+         (expr2 (h:list->vector '(1 2 3 4))))
+    (force expr1)
+    (test-equal "effect" 0 effect)
+    (test-equal "works"
+                '#(1 2 3 4)
+                (recursive-force expr1))
+    (test-equal "works with constant"
+                '#(1 2 3 4)
+                (recursive-force expr2))))
+
+(define (test-list-copy)
+  (test-equal "works"
+              '(1 2 3 4)
+              (recursive-force
+               (h:list-copy (h:list 1 2 3 4)))))
+
+(define (test-other-binding-constructs)
+  (test-equal "let*"
+              1
+              (force (h:let* ((x 0)
+                              (x (h:+ x 1)))
+                             x)))
+  (test-assert "letrec"
+               (force (h:letrec ((odd? (h:lambda (x)
+                                         (h:if (h:zero? x)
+                                               #f
+                                               (even? (h:- x 1)))))
+                                 (even? (h:lambda (x)
+                                          (h:if (h:zero? x)
+                                                #t
+                                                (odd? (h:- x 1))))))
+                                (even? 88))))
+  (test-equal "letrec*"
+              5
+              (force (h:letrec* ((p (h:lambda (x)
+                                      (h:+ 1 (q (h:- x 1)))))
+                                 (q (h:lambda (y)
+                                      (h:if (h:zero? y)
+                                            0
+                                            (h:+ 1 (p (h:- y 1))))))
+                                 (x (p 5))
+                                 (y x))
+                                y))))
+
+#;(define (test-misc-wrapped-procedures)
+    (let-syntax ((test-wrapped
+                  (syntax-rules ()
+                    ((_ proc h:proc (args ...) ...)
+                     (test-group (symbol->string 'proc)
+                       (test-equal (proc args ...)
+                                   (force (h:proc args ...)))
+                       ...)))))
+      (test-wrapped eq? h:eq?
+                    (#f #f)
+                    (#t #t)
+                    (#f #t)
+                    ('() '())
+                    ('() 'a)
+                    ('a 'a)
+                    ('a 'b))
+      (test-wrapped eqv? h:eqv?
+                    (#f #f)
+                    (#t #t)
+                    (#f #t)
+                    ('() '())
+                    ('() 'a)
+                    ('a 'a)
+                    ('a 'b)
+                    (1 1)
+                    (1 2))
+      (test-wrapped exact-integer? h:exact-integer?
+                    (1) (2) (0) (0.1))
+      (test-wrapped negative? h:negative?
+                    (-1) (0) (1))
+      (test-wrapped positive? h:positive?
+                    (-1) (0) (1))
+      (test-wrapped zero? h:zero?
+                    (-1) (0) (1))
+      (test-wrapped + h:+
+                    (0) (0 0) (1 0))
+      (test-wrapped)))
\ No newline at end of file
diff --git a/lib/tests/hascheme/base.sld b/lib/tests/hascheme/base.sld
index 11b96d7..591c53f 100644
--- a/lib/tests/hascheme/base.sld
+++ b/lib/tests/hascheme/base.sld
@@ -2,820 +2,7 @@
   (import (scheme base)
           (hascheme eager)
           (hascheme support)
-          (prefix (hascheme base) h:))
-  (cond-expand
-    (chicken-6 (import (except (test) test test-equal)
-                   (rename (only (test) test) (test test-equal))))
-    (chibi (import (except (chibi test) test test-equal)
-                   (rename (only (chibi test) test) (test test-equal))))
-    (else (import (srfi 64))))
+          (prefix (hascheme base) h:)
+          (tests hascheme kiss-test))
   (export test-base)
-  (begin
-    (define-syntax h:set!
-      (syntax-rules ()
-        ((_ name value) (delay (set! name value)))))
-    (define (test-base)
-      (test-group "SRFI-45" (test-srfi-45))
-      (test-group "preliminaries" (test-preliminaries))
-      (test-group "lambda" (test-lambda))
-      (test-group "if" (test-if))
-      (test-group "cond" (test-cond))
-      (test-group "do" (test-do))
-      (test-group "case" (test-case))
-      (test-group "and" (test-and))
-      (test-group "or" (test-or))
-      (test-group "when and unless" (test-when-and-unless))
-      (test-group "record types" (test-record-types))
-      (test-group "apply" (test-apply))
-      (test-group "floor/" (test-converted-number-function h:floor/
-                                                           -5 2
-                                                           '(-3 1)))
-      (test-group "truncate/" (test-converted-number-function h:truncate/
-                                                              -5 2
-                                                              '(-2 -1)))
-      (test-group "exact-integer-sqrt" (test-exact-integer-sqrt))
-      (test-group "equal?" (my-test-equal?))
-      (test-group "wrappers from strict" (test-wrappers-from-strict))
-      (test-group "constructors" (test-constructors))
-      (test-group "binary wrappers" (test-binary-wrappers))
-      (test-group "vector-map" (test-vector-map))
-      (test-group "list?" (test-list?))
-      (test-group "make-list" (test-make-list))
-      (test-group "length" (test-length))
-      (test-group "append" (test-append))
-      (test-group "reverse" (test-reverse))
-      (test-group "list-tail" (test-list-tail))
-      (test-group "list-ref" (test-list-ref))
-      (test-group "member" (test-member))
-      (test-group "assoc" (test-assoc))
-      (test-group "map" (test-map))
-      (test-group "list->string" (test-list->string))
-      (test-group "make-vector" (test-make-vector))
-      (test-group "list->vector" (test-list->vector))
-      (test-group "list-copy" (test-list-copy))
-      (test-group "other binding constructors" (test-other-binding-constructs)))
-    (define (test-srfi-45)
-      #| These tests are taken from SRFI-45.
-
-Copyright (C) André van Tonder (2003). All Rights Reserved.
-
-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. |#
-      (test-group "memo 1"
-        (let* ((effect 0)
-               (expr (delay (begin (set! effect (+ effect 1)) 10))))
-          (test-equal 0 effect)
-          (test-equal 10 (force expr))
-          (test-equal 1 effect)
-          (test-equal 10 (force expr))
-          (test-equal 1 effect)))
-      (test-group "memo 2"
-        (let* ((effect 0)
-               (expr (delay (begin (set! effect (+ effect 1)) 2))))
-          (test-equal 4 (+ (force expr) (force expr)))
-          (test-equal 1 effect)))
-      (test-group "memo 3"
-        (let* ((effect 0)
-               (r (delay (begin (set! effect (+ effect 1)) 1)))
-               (s (delay-force r))
-               (t (delay-force s)))
-          (test-equal 1 (force s))
-          (test-equal 1 (force t))
-          (test-equal 1 effect)))
-      (test-group "memo 4"
-        (letrec* ((effect 0)
-                  (stream-drop (lambda (s index)
-                                 (delay-force
-                                  (if (zero? index)
-                                      s
-                                      (stream-drop (cdr (force s))
-                                                   (- index 1))))))
-                  (ones (lambda () (delay (begin
-                                            (set! effect (+ effect 1))
-                                            (cons 1 (ones))))))
-                  (s (ones)))
-          (test-equal 0 effect)
-          (test-equal 1 (car (force (stream-drop s 4))))
-          (test-equal "effect, 1" 5 effect)
-          (test-equal 1 (car (force (stream-drop s 4))))
-          (test-equal "effect, 2" 5 effect)
-          (test-equal 1 (car (force (stream-drop s 4))))
-          (test-equal "effect, 3" 5 effect)))
-      (test-group "reenter 1"
-        (letrec* ((count 0)
-                  (p (delay (begin (set! count (+ count 1))
-                                   (if (> count x)
-                                       count
-                                       (force p)))))
-                  (x 5))
-          (test-equal 6 (force p))
-          (set! x 10)
-          (test-equal 6 (force p))))
-      (test-group "reenter 2"
-        (letrec* ((first? #t)
-                  (f (delay (if first?
-                                (begin
-                                  (set! first? #f)
-                                  (force f))
-                                'second))))
-          (test-equal 'second (force f))))
-      (test-group "reenter 3"
-        (letrec* ((count 5)
-                  (p (delay (if (<= count 0)
-                                count
-                                (begin (set! count (- count 1))
-                                       (force p)
-                                       (set! count (+ count 2))
-                                       count)))))
-          (test-equal 5 count)
-          (test-equal 0 (force p))
-          (test-equal 10 count))))
-    (define (test-preliminaries)
-      (test-assert "forcing a value is valid"
-        (let ((ok (lambda (x) (equal? (force x) x))))
-          (and (ok #t)
-               (ok #\x)
-               (ok 0)
-               (ok "a")
-               (ok 'a)
-               (ok '(1 2 3))
-               (ok '#(1 2 3))
-               (ok (list 1 2 3))
-               (ok (vector 1 2 3))
-               (ok '())
-               (ok #u8(1 2 3))
-               (ok (lambda (x) x)))))
-      (let* ((x 0)
-             (expr (h:set! x (+ x 1))))
-        (test-assert "set! returns a promise"
-          (promise? expr))
-        (test-equal "set! has not run yet"
-                    0
-                    x)
-        (force expr)
-        (test-equal "set! is effectful"
-                    1
-                    x)
-        (force expr)
-        (test-equal "set! does not run more than once"
-                    1
-                    x)))
-    (define (test-lambda)
-      (test-assert "lambda returns a procedure"
-        (procedure? (h:lambda (x) x)))
-      (test-assert "application of lambda returns a promise"
-        (promise? ((h:lambda (x) x) 5)))
-      (test-equal "forcing a promise returns the value"
-                  5
-                  (force ((h:lambda (x) x) 5)))
-      (let ()
-        (h:define (id x) x)
-        (test-assert "internal define is a procedure"
-          (procedure? id)))
-      (let* ((effect 'not-run)
-             (expr (h:lambda (x y) x)))
-        (force (expr (h:set! effect 'run) (h:set! effect 'error)))
-        (test-equal "lambda is not non-strict"
-                    'run
-                    effect)))
-    (define (test-if)
-      (test-assert "if returns a promise"
-        (promise? (h:if #t #t #f)))
-      (test-equal "forcing if runs it"
-                  'true
-                  (force (h:if #t 'true 'false)))
-      (let* ((effect 'not-run)
-             (test-effect 'not-run)
-             (expr (h:if (h:seq (h:set! test-effect 'run)
-                                #f)
-                         (h:set! effect 'true)
-                         (h:set! effect 'false))))
-        (test-equal "creation of if does not run anything"
-                    'not-run
-                    effect)
-        (test-equal "creation of if does not run anything, 2"
-                    'not-run
-                    test-effect)
-        (force expr)
-        (test-equal "if is eager in the predicate"
-                    'run
-                    test-effect)
-        (test-equal "forcing if forces the path"
-                    'false
-                    effect)))
-    (define (test-let)
-      (test-equal "let works as normal"
-                  5
-                  (h:let ((x 5))
-                    x))
-      (let ((loop (h:let loop ((x 0))
-                    (if (< x 10)
-                        (loop (+ x 1))
-                        x))))
-        (test-assert "named let returns a promise"
-          (promise? loop))
-        (test-equal "forcing named let runs the promise"
-                    10
-                    (force loop))))
-    (define (test-do)
-      (let ((loop (h:do ((l '(a b c) (h:cdr l))
-                         (acc 0 (h:+ acc 1)))
-                        ((h:null? l) acc))))
-        (test-assert "do returns a promise"
-          (promise? loop))
-        (test-equal "do runs when forced"
-                    3
-                    (force loop)))
-      (let* ((effect 0)
-             (loop (h:do ((l '(a b c) (h:cdr l)))
-                         ((h:null? l))
-                     (h:set! effect (+ effect 1)))))
-        (test-equal "do has not run yet"
-                    0
-                    effect)
-        (force loop)
-        (test-equal "do runs its body for effects, fresh each time"
-                    3
-                    effect)))
-    (define (test-seq)
-      (test-assert "seq returns a promise"
-        (promise? (h:seq #t #t #t)))
-      (test-equal "seq returns its last argument"
-                  5
-                  (force (h:seq 0 1 2 3 4 5)))
-      (let ((effect1 0)
-            (effect2 0))
-        (test-equal "force has not run yet"
-                    '(0 0)
-                    (list effect1 effect2))
-        (force (h:seq (h:set! effect1 1) (h:set! effect2 2)))
-        (test-equal "seq forces all arguments"
-                    '(1 2)
-                    (list effect1 effect2))))
-    (define (test-cond)
-      ;; TODO: Test on non-CHICKEN systems.
-      (cond-expand
-        (chicken
-         (test-assert "cond returns a promise"
-           (promise? (h:cond (#t #t) (else #f))))
-         (let ((x 1))
-           (test-equal "cond works like cond"
-                       'true
-                       (force (h:cond
-                                ((h:= x 0) 0)
-                                ((h:= x 1) 'true)
-                                (else 'false)))))
-         (let* ((effect 'not-run)
-                (expr (h:cond
-                        ((h:seq (h:set! effect 'run-once)
-                                #t) #t)
-                        (else (h:set! effect 'false) #f))))
-           (test-equal "cond has not run yet"
-                       'not-run
-                       effect)
-           (test-assert "cond works like cond, 2"
-             (force expr))
-           (test-equal "cond has made an effect"
-                       'run-once
-                       effect)))))
-    (define (test-case)
-      (cond-expand
-        (chicken
-         (let ((expr (h:case 5
-                       ((1 2 3 4) 'a)
-                       ((5 6 7 8) 'b)
-                       (else 'c))))
-           (test-assert "case returns a promise"
-             (promise? expr))
-           (test-equal "case runs as normal"
-                       'b
-                       (force expr))))))
-    (define (test-and)
-      (let* ((effect 0)
-             (expr (h:and 1 2 3 (h:seq (h:set! effect 1) #f)
-                          (h:seq (h:set! effect 2) #t))))
-        (test-assert "and returns a promise"
-          (promise? expr))
-        (test-equal "and has not run yet"
-                    0
-                    effect)
-        (test-assert "and runs as normal for falses"
-          (not (force expr)))
-        (test-equal "and is non-strict"
-                    1
-                    effect))
-      (test-equal "and runs as normal for truthy"
-                  5
-                  (force (h:and 1 2 3 4 5)))
-      (test-assert "and run as normal for the zero argument case"
-        (h:and)))
-    (define (test-or)
-      (let* ((effect 0)
-             (expr (h:or #f #f #f (h:seq (h:set! effect 1) #t)
-                         (h:seq (h:set! effect 2) #f))))
-        (test-assert "or returns a promise"
-          (promise? expr))
-        (test-equal "or has not run yet"
-                    0
-                    effect)
-        (test-assert "or runs as normal for truths"
-          (force expr))
-        (test-equal "or is non-strict"
-                    1
-                    effect))
-      (test-assert "or runs as normal for falses"
-        (not (force (h:or #f #f))))
-      (test-assert "or runs as normal for the zero argument case"
-        (not (force (h:or)))))
-    (define (test-when-and-unless)
-      (let* ((effect 0)
-             (expr1 (h:when #f (h:set! effect 1)))
-             (expr2 (h:unless #t (h:set! effect 2))))
-        (test-assert "when returns a promise"
-          (promise? expr1))
-        (test-assert "unless returns a promise"
-          (promise? expr2))
-        (test-equal "neither have run yet"
-                    0
-                    effect)
-        (force expr1)
-        (test-equal "when acts as normal for false cases"
-                    0
-                    effect)
-        (force expr2)
-        (test-equal "unless acts as normal for true cases"
-                    0
-                    effect))
-      (let* ((effect 0)
-             (expr1 (h:when (h:and) (h:set! effect 1)))
-             (expr2 (h:unless (h:or) (h:set! effect 2))))
-        (force expr1)
-        (test-equal "when acts as normal for true cases"
-                    1
-                    effect)
-        (force expr2)
-        (test-equal "unless acts as normal for false cases"
-                    2
-                    effect)))
-    (define (test-record-types)
-      (h:define-record-type <test>
-        (kons kar kdr kbr)
-        kons?
-        (kar kar)
-        (kdr kdr)
-        (kbr kbr))
-      (let* ((effect 0)
-             (expr (kons (h:seq (h:set! effect 1)
-                                10)
-                         (h:seq (h:set! effect 2)
-                                20)
-                         (h:seq (h:set! effect 3)
-                                30))))
-        (test-assert "constructor returns a promise"
-          (promise? expr))
-        (test-assert "forcing returns a value that the predicate accepts"
-          (force (kons? expr)))
-        (test-equal "constructor is not strict in any argument"
-                    0
-                    effect)
-        (test-equal "accessor 2"
-                    20
-                    (force (kdr expr)))
-        (test-equal "accessor is strict in its argument"
-                    2
-                    effect)
-        (test-equal "accessor 3"
-                    30
-                    (force (kbr expr)))
-        (test-equal "accessor 3 is strict in its argument"
-                    3
-                    effect)
-        (test-equal "accessor 1"
-                    10
-                    (force (kar expr)))
-        (test-equal "accessor 1 is strict in its argument"
-                    1
-                    effect)))
-    (define (test-apply)
-      (let* ((effect 0)
-             (effect2 0)
-             (effect3 0)
-             (expr (h:apply (h:seq (h:set! effect 1) (h:lambda (x y) x))
-                            (h:seq (h:set! effect2 1) 1)
-                            (h:list (h:seq (h:set! effect3 1) 2)))))
-        (test-assert "apply returns a promise"
-          (promise? expr))
-        (test-equal "apply has not run yet"
-                    '(0 0 0)
-                    (list effect effect2 effect3))
-        (test-equal "apply runs as expected"
-                    1
-                    (force expr))
-        (test-equal "apply is strict in its first argument"
-                    1
-                    effect)
-        (test-equal "apply is strict as its input function"
-                    1
-                    effect2)
-        (test-equal "apply is not strict where its input is not"
-                    0
-                    effect3)))
-    (define (test-converted-number-function proc in1 in2 out)
-      (let* ((effect1 0)
-             (effect2 0)
-             (expr (proc (h:seq (h:set! effect1 2)
-                                in1)
-                         (h:seq (h:set! effect2 3)
-                                in2))))
-        (test-assert "returns a promise"
-          (promise? expr))
-        (test-equal "not run yet"
-                    '(0 0)
-                    (list effect1 effect2))
-        (test-equal "returns correct values"
-                    out
-                    (recursive-force expr))
-        (test-equal "effects"
-                    '(2 3)
-                    (list effect1 effect2))))
-    (define (test-exact-integer-sqrt)
-      (test-equal "works"
-                  '(2 1)
-                  (recursive-force (h:exact-integer-sqrt 5))))
-    (define (test-wrappers-from-strict)
-      (test-assert "pair?"
-        (force (h:pair? (h:cons 1 2)))))
-    (define (test-constructors)
-      (test-group "cons"
-        (let* ((effect1 0)
-               (effect2 0)
-               (expr (h:cons (h:seq (h:set! effect1 1) 1)
-                             (h:seq (h:set! effect2 1) 2))))
-          (force expr)
-          (test-equal "cons is not strict"
-                      '(0 0)
-                      (list effect1 effect2))
-          (test-equal "accessing car works"
-                      1
-                      (force (h:car expr)))
-          (test-equal "effects after car"
-                      '(1 0)
-                      (list effect1 effect2))
-          (test-equal "accessing cdr works"
-                      2
-                      (force (h:cdr expr)))
-          (test-equal "effects after cdr"
-                      '(1 1)
-                      (list effect1 effect2))
-          (test-equal "recursive force"
-                      '(1 . 2)
-                      (recursive-force expr)))))
-    (define (test-binary-wrappers)
-      (let* ((effect1 0)
-             (effect2 0)
-             (effect3 0)
-             (effect4 0)
-             (expr (h:< (h:seq (h:set! effect1 1) 1)
-                        (h:seq (h:set! effect2 1) 2)
-                        (h:seq (h:set! effect3 1) 0)
-                        (h:seq (h:set! effect4 1) 10))))
-        (test-assert "< returns a promise"
-          (promise? expr))
-        (test-equal "< has not run yet"
-                    '(0 0 0 0)
-                    (list effect1 effect2 effect3 effect4))
-        (test-assert "< works for the false case"
-          (not (force expr)))
-        (test-equal "< is not necessarily strict"
-                    '(1 1 1 0)
-                    (list effect1 effect2 effect3 effect4))))
-    (define (test-vector-map)
-      (let* ((effect1 0)
-             (effect2 0)
-             (expr (h:vector-map (h:lambda (x y) (h:+ x y))
-                                 (h:seq (h:set! effect1 1)
-                                        (h:vector 1 2 3))
-                                 (h:vector 4 5 6 (h:seq (h:set! effect2 1)
-                                                        7)))))
-        (test-assert "vector-map returns a promise"
-          (promise? expr))
-        (test-assert "vector-map forced returns a vector"
-          (vector? (force expr)))
-        (test-equal "vector-map is non-strict"
-                    '(1 0)
-                    (list effect1 effect2))
-        (test-equal "vector-map returns as expected"
-                    '#(5 7 9)
-                    (recursive-force expr))))
-    (define (my-test-equal?)
-      (test-group "equal? on equal lists"
-        (let* ((effect1 0)
-               (effect2 0)
-               (effect3 0)
-               (effect4 0)
-               (expr (h:equal? (h:list (h:seq (h:set! effect1 1) 1)
-                                       (h:seq (h:set! effect2 1) 2))
-                               (h:list (h:seq (h:set! effect3 1) 1)
-                                       (h:seq (h:set! effect4 1) 2)))))
-          (test-assert "equal" (force expr))
-          (test-equal "equal? is strict on equal values"
-                      '(1 1 1 1)
-                      (list effect1 effect2 effect3 effect4))))
-      (test-group "equal? on unequal lists"
-        (let* ((effect1 0)
-               (effect2 0)
-               (effect3 0)
-               (expr (h:equal? (h:list (h:seq (h:set! effect1 1) 1))
-                               (h:list (h:seq (h:set! effect2 1) 1)
-                                       (h:seq (h:set! effect3 1) 2)))))
-          (test-assert "not equal" (not (force expr)))
-          (test-equal "equal? is not strict in all values"
-                      '(1 1 0)
-                      (list effect1 effect2 effect3))))
-      (test-group "equal? on equal vectors"
-        (let* ((effect1 0)
-               (effect2 0)
-               (effect3 0)
-               (effect4 0)
-               (expr (h:equal? (h:vector (h:seq (h:set! effect1 1) 1)
-                                         (h:seq (h:set! effect2 1) 2))
-                               (h:vector (h:seq (h:set! effect3 1) 1)
-                                         (h:seq (h:set! effect4 1) 2)))))
-          (test-assert "equal" (force expr))
-          (test-equal "equal? is strict on equal values"
-                      '(1 1 1 1)
-                      (list effect1 effect2 effect3 effect4))))
-      (test-group "equal? on unequal vectors"
-        (let* ((effect1 0)
-               (effect2 0)
-               (effect3 0)
-               (expr (h:equal? (h:vector (h:seq (h:set! effect1 1) 1))
-                               (h:vector (h:seq (h:set! effect2 1) 1)
-                                         (h:seq (h:set! effect3 1) 2)))))
-          (test-assert "not equal" (not (force expr)))
-          (test-equal "equal? is not strict in all values"
-                      '(0 0 0)
-                      (list effect1 effect2 effect3)))))
-    (define (test-list?)
-      (let* ((effect1 0)
-             (effect2 0)
-             (expr (h:list? (h:cons (h:seq (h:set! effect1 1) 1)
-                                    (h:seq (h:set! effect2 1)
-                                           (h:cons 2 '()))))))
-        (test-equal "expression has not run yet"
-                    '(0 0)
-                    (list effect1 effect2))
-        (test-assert "list? works"
-          (force expr))
-        (test-equal "list? does not force the values of the list"
-                    '(0 1)
-                    (list effect1 effect2))))
-    (define (test-make-list)
-      (let* ((effect 0)
-             (expr (h:make-list (h:seq (h:set! effect (+ effect 1)) 5) 10)))
-        (test-assert "expr makes a list"
-          (force (h:list? expr)))
-        (test-equal "make-list is strict in its first argument"
-                    1
-                    effect)
-        (test-equal "first element"
-                    10
-                    (force (h:car expr)))
-        (test-equal "second element"
-                    10
-                    (force (h:cadr expr)))
-        (test-equal "recursive force"
-                    '(10 10 10 10 10)
-                    (recursive-force expr)))
-      (let* ((expr (h:make-list +inf.0 10)))
-        (test-equal "infinity is OK"
-                    10
-                    (force (h:cadr expr)))))
-    (define (test-length)
-      (let* ((effect1 0)
-             (effect2 0)
-             (effect3 0)
-             (expr (h:length (h:list (h:seq (h:set! effect1 1) 1)
-                                     (h:seq (h:set! effect2 1) 2)
-                                     (h:seq (h:set! effect3 1) 3)))))
-        (test-equal "length works on lists"
-                    3
-                    (force expr))
-        (test-equal "length does not force values in the list"
-                    '(0 0 0)
-                    (list effect1 effect2 effect3))))
-    (define (test-append)
-      (test-equal "zero argument case" '() (force (h:append)))
-      (test-group "single argument case"
-        (let* ((effect 0)
-               (expr (h:append (h:seq (h:set! effect 1) 1))))
-          (test-equal "returns its argument"
-                      1
-                      (force expr))))
-      (test-group "multiple lists"
-        (let* ((effect0 0)
-               (effect1 0)
-               (effect2 0)
-               (expr (h:append (h:seq (h:set! effect0 1)
-                                      (h:list (h:seq (h:set! effect1 1) 1)
-                                              2))
-                               (h:seq (h:set! effect2 1) '(3 4)))))
-          (force expr)
-          (test-equal "strict in all arguments except the last"
-                      '(1 0 0)
-                      (list effect0 effect1 effect2))
-          (test-equal "append works as expected"
-                      '(1 2 3 4)
-                      (recursive-force expr)))))
-    (define (test-reverse)
-      (let* ((effect0 0)
-             (effect1 0)
-             (expr (h:reverse (h:seq (h:set! effect0 1)
-                                     (h:list (h:seq (h:set! effect1 1) 1)
-                                             2
-                                             3)))))
-        (force expr)
-        (test-equal "reverse is strict in the pairs, not the values"
-                    '(1 0)
-                    (list effect0 effect1))
-        (test-equal "reverse works as expected"
-                    '(3 2 1)
-                    (recursive-force expr))))
-    (define (test-list-tail)
-      (let* ((effect0 0)
-             (effect1 0)
-             (effect2 0)
-             (expr (h:list-tail (h:seq (h:set! effect0 1)
-                                       (h:list (h:seq (h:set! effect1 1) 1)
-                                               2
-                                               3
-                                               4))
-                                (h:seq (h:set! effect2 1)
-                                       2))))
-        (force expr)
-        (test-equal "list-tail is strict in both arguments, pairs only"
-                    '(1 0 1)
-                    (list effect0 effect1 effect2))
-        (test-equal "list-tail works as expected"
-                    '(3 4)
-                    (recursive-force expr))
-        (test-equal "list-tail never evaluates discarded values"
-                    0
-                    effect1)))
-    (define (test-list-ref)
-      (let* ((effect0 0)
-             (effect1 0)
-             (effect2 0)
-             (effect3 0)
-             (effect4 0)
-             (expr (h:list-ref (h:seq (h:set! effect0 1)
-                                      (h:list (h:seq (h:set! effect1 1) 1)
-                                              2
-                                              (h:seq (h:set! effect2 1) 3)
-                                              (h:seq (h:set! effect3 1) 4)))
-                               (h:seq (h:set! effect4 1) 2))))
-        (test-equal "evaluated to"
-                    3
-                    (force expr))
-        (test-equal "strictness of forcing the expression"
-                    '(1 0 1 0 1)
-                    (list effect0 effect1 effect2 effect3 effect4))))
-    (define (test-member)
-      (let* ((effect 0)
-             (expr (h:member 10 (h:let loop ((x 0))
-                                  (h:seq (h:set! effect (force x))
-                                         (h:cons x (loop (h:+ x 1))))))))
-        (test-equal "member works as expected"
-                    10
-                    (force (h:car expr)))
-        (test-equal "side effects"
-                    10
-                    effect)))
-    (define (test-assoc)
-      (let* ((effect 0)
-             (expr (h:assoc 10 (h:let loop ((x 0)
-                                            (y 2))
-                                 (h:seq (h:set! effect (force x))
-                                        (h:cons (h:cons x y)
-                                                (loop (h:+ x 1)
-                                                      (h:* y 2))))))))
-        (test-equal "assoc works as expected"
-                    '(10 . 2048)
-                    (recursive-force expr))
-        (test-equal "side effects"
-                    10
-                    effect)))
-    (define (test-map)
-      (let* ((expr (h:map h:+ '(1 2 3 4) '(10 20 30 40))))
-        (test-equal "works"
-                    '(11 22 33 44)
-                    (recursive-force expr))))
-    (define (test-list->string)
-      (let* ((expr1 (h:list->string (h:list #\x #\y #\z)))
-             (expr2 (h:list->string '(#\x #\y #\z))))
-        (test-assert "works"
-          (string=? (force expr1) (force expr2) "xyz"))))
-    (define (test-make-vector)
-      (let* ((effect 0)
-             (expr (h:make-vector (h:seq (h:set! effect (+ effect 1)) 10) 0)))
-        (test-equal "works"
-                    '#(0 0 0 0 0 0 0 0 0 0)
-                    (recursive-force expr))
-        (test-equal "effects" 1 effect)))
-    (define (test-list->vector)
-      (let* ((effect 0)
-             (expr1 (h:list->vector (h:list (h:seq (h:set! effect 1) 1)
-                                            2 3 4)))
-             (expr2 (h:list->vector '(1 2 3 4))))
-        (force expr1)
-        (test-equal "effect" 0 effect)
-        (test-equal "works"
-                    '#(1 2 3 4)
-                    (recursive-force expr1))
-        (test-equal "works with constant"
-                    '#(1 2 3 4)
-                    (recursive-force expr2))))
-    (define (test-list-copy)
-      (test-equal "works"
-                  '(1 2 3 4)
-                  (recursive-force
-                   (h:list-copy (h:list 1 2 3 4)))))
-    (define (test-other-binding-constructs)
-      (test-equal "let*"
-                  1
-                  (force (h:let* ((x 0)
-                                  (x (h:+ x 1)))
-                           x)))
-      (test-assert "letrec"
-        (force (h:letrec ((odd? (h:lambda (x)
-                                  (h:if (h:zero? x)
-                                        #f
-                                        (even? (h:- x 1)))))
-                          (even? (h:lambda (x)
-                                   (h:if (h:zero? x)
-                                         #t
-                                         (odd? (h:- x 1))))))
-                 (even? 88))))
-      (test-equal "letrec*"
-                  5
-                  (force (h:letrec* ((p (h:lambda (x)
-                                          (h:+ 1 (q (h:- x 1)))))
-                                     (q (h:lambda (y)
-                                          (h:if (h:zero? y)
-                                                0
-                                                (h:+ 1 (p (h:- y 1))))))
-                                     (x (p 5))
-                                     (y x))
-                           y))))
-    #;(define (test-misc-wrapped-procedures)
-        (let-syntax ((test-wrapped
-                      (syntax-rules ()
-                        ((_ proc h:proc (args ...) ...)
-                         (test-group (symbol->string 'proc)
-                           (test-equal (proc args ...)
-                                       (force (h:proc args ...)))
-                           ...)))))
-          (test-wrapped eq? h:eq?
-                        (#f #f)
-                        (#t #t)
-                        (#f #t)
-                        ('() '())
-                        ('() 'a)
-                        ('a 'a)
-                        ('a 'b))
-          (test-wrapped eqv? h:eqv?
-                        (#f #f)
-                        (#t #t)
-                        (#f #t)
-                        ('() '())
-                        ('() 'a)
-                        ('a 'a)
-                        ('a 'b)
-                        (1 1)
-                        (1 2))
-          (test-wrapped exact-integer? h:exact-integer?
-                        (1) (2) (0) (0.1))
-          (test-wrapped negative? h:negative?
-                        (-1) (0) (1))
-          (test-wrapped positive? h:positive?
-                        (-1) (0) (1))
-          (test-wrapped zero? h:zero?
-                        (-1) (0) (1))
-          (test-wrapped + h:+
-                        (0) (0 0) (1 0))
-          (test-wrapped)))))
\ No newline at end of file
+  (include "base.scm"))
\ No newline at end of file
diff --git a/lib/tests/hascheme/kiss-test.scm b/lib/tests/hascheme/kiss-test.scm
new file mode 100644
index 0000000..a5a2956
--- /dev/null
+++ b/lib/tests/hascheme/kiss-test.scm
@@ -0,0 +1,119 @@
+(define %tests-passed 0)
+(define (tests-passed) %tests-passed)
+(define (increment-tests-passed! x)
+  (set! %tests-passed (+ %tests-passed x)))
+
+(define %tests-failed 0)
+(define (tests-failed) %tests-failed)
+(define (increment-tests-failed! x)
+  (set! %tests-failed (+ %tests-failed x)))
+
+(define (call-as-test thunk on-success on-failure on-ex)
+  (let ((returned-value
+         (call/cc
+          (lambda (return)
+            (with-exception-handler
+                (lambda (ex) (return (on-ex ex)))
+              thunk)))))
+    (if returned-value
+        (on-success returned-value)
+        (on-failure returned-value))))
+
+(define (call-as-test-assert name thunk)
+  (call-as-test thunk
+                (lambda (x)
+                  (increment-tests-passed! 1))
+                (lambda (x)
+                  (display (list name 'failed))
+                  (newline)
+                  (increment-tests-failed! 1))
+                (lambda (ex)
+                  (display (list name 'exception ex))
+                  (newline)
+                  #f)))
+
+(define-syntax test-assert
+  (syntax-rules ()
+    ((_ expr) (test-assert "test" expr))
+    ((_ name expr) (call-as-test-assert name (lambda () expr)))))
+
+(define (call-as-test-equal name predicate? expected actual)
+  (call-as-test (lambda () (predicate? expected actual))
+                (lambda (x)
+                  (increment-tests-passed! 1))
+                (lambda (x)
+                  (display (list name expected '!= actual))
+                  (newline)
+                  (increment-tests-failed! 1))
+                (lambda (ex)
+                  (display (list name 'exception ex))
+                  (newline)
+                  #f)))
+
+(define-syntax test-equal
+  (syntax-rules ()
+    ((_ expected actual)
+     (test-equal "equal?" expected actual))
+    ((_ name expected actual)
+     (call-as-test-equal name equal? expected actual))))
+
+(define-syntax test-eqv
+  (syntax-rules ()
+    ((_ expected actual) (test-eqv "eqv?" expected actual))
+    ((_ name expected actual)
+     (call-as-test-equal name eqv? expected actual))))
+
+(define-syntax test-eq
+  (syntax-rules ()
+    ((_ expected actual) (test-eq "eq?" expected actual))
+    ((_ name expected actual)
+     (call-as-test-equal name eq? expected actual))))
+
+(define (call-as-test-exception name thunk predicate?)
+  (let* ((raised? #f)
+         (the-exception #f)
+         (on-ex (lambda (obj)
+                  (set! raised? #t)
+                  (set! the-exception obj)
+                  (cond
+                    ((eq? predicate? #t) #t)
+                    (else (predicate? obj))))))
+    (call-as-test (lambda () (thunk) #f)
+                  (lambda (x)
+                    (increment-tests-passed! 1))
+                  (lambda (_)
+                    (if raised?
+                        (display (list name 'bad-exception
+                                       the-exception))
+                        (display (list name 'no-exception)))
+                    (newline)
+                    (increment-tests-failed! 1))
+                  on-ex)))
+
+(define-syntax test-error
+  (syntax-rules ()
+    ((_ predicate? expr) (test-error "test-exception" predicate? expr))
+    ((_ name predicate? expr)
+     (call-as-test-exception name
+                             (lambda () expr)
+                             predicate?))))
+
+(define-syntax test-group
+  (syntax-rules ()
+    ((_ name body ...)
+     (let ((passed (tests-passed)) (failed (tests-failed)))
+       (display (list 'group name))
+       (newline)
+       (let () body ...)
+       (let ((passed-in-group (- (tests-passed) passed))
+             (failed-in-group (- (tests-failed) failed)))
+         (display (list 'group name
+                        'passed passed-in-group
+                        'failed failed-in-group))
+         (newline))))))
+
+(define (test-exit)
+  (display (list 'passed (tests-passed)
+                 'failed (tests-failed)))
+  (newline)
+  (exit (if (zero? (tests-failed)) 0 1)))
diff --git a/lib/tests/hascheme/kiss-test.sld b/lib/tests/hascheme/kiss-test.sld
new file mode 100644
index 0000000..52ee2a3
--- /dev/null
+++ b/lib/tests/hascheme/kiss-test.sld
@@ -0,0 +1,11 @@
+(define-library (tests hascheme kiss-test)
+  (import (scheme base) (scheme write) (scheme process-context))
+  (export tests-passed increment-tests-passed!
+          tests-failed increment-tests-failed!
+          call-as-test
+          call-as-test-assert test-assert
+          call-as-test-equal test-equal test-eqv test-eq
+          call-as-test-exception test-error
+          test-group
+          test-exit)
+  (include "kiss-test.scm"))
\ No newline at end of file
diff --git a/tests/run.scm b/tests/run.scm
index 1036295..20023f3 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,15 +1,11 @@
 (cond-expand
-  (chicken-6 (import (test))
-             (load "../lib/tests/hascheme/base.sld"))
-  (chibi (import (chibi test)))
-  (else (import (srfi 64))))
+ (chicken-6 (load "../lib/tests/hascheme/kiss-test.sld")
+            (load "../lib/tests/hascheme/base.sld"))
+ (else))
 
-(import (scheme process-context) (tests hascheme base))
+(import (scheme process-context) (tests hascheme base)
+        (tests hascheme kiss-test))
 (test-group "base" (test-base))
+(test-exit)
 
-(cond-expand
-  ((or chibi chicken-6) (test-exit))
-  (else (exit (if (zero? (test-runner-fail-count (test-runner-current)))
-                  0
-                  1))))