tests, chibi support

11 files changed, 1504 insertions, 77 deletions

diff --git a/lib/hascheme/base.scm b/lib/hascheme/base.scm
index 8f2f927..7a2a7a5 100644
--- a/lib/hascheme/base.scm
+++ b/lib/hascheme/base.scm
@@ -1,9 +1,10 @@
 (define-syntax let
   ;; Named let needs to be modified to use lazy lambda
   (syntax-rules ()
-    ((let ((formal expr) ...) body ...)
+    ((_ ()) #f)
+    ((_ ((formal expr) ...) body ...)
      (r7rs:let ((formal expr) ...) body ...))
-    ((let name ((formal expr) ...) body ...)
+    ((_ name ((formal expr) ...) body ...)
      (letrec ((name (lambda (formal ...) body ...)))
        (name expr ...)))))
 
@@ -11,59 +12,68 @@
   (syntax-rules ()
     ((if x y ...) (delay-force (r7rs:if (! x) y ...)))))
 
+(define-syntax do
+  (syntax-rules ()
+    ((_ ((arg init update ...) ...)
+        (condition body ...)
+        inner-body ...)
+     (let loop ((arg init) ...)
+       (if condition
+           (let () body ...)
+           (seq (let () inner-body ...)
+                (let-syntax ((do-update
+                              (syntax-rules ()
+                                ((_ %init) %init)
+                                ((_ _ %update) %update))))
+                  (loop (do-update init update ...) ...))))))))
+
 (define-syntax cond
   (syntax-rules (else =>)
-    ((cond "iter" (else result1 result2 ...))
+    ((cond (else result1 result2 ...))
      (let () result1 result2 ...))
-    ((cond "iter" (test => result))
+    ((cond (test => result))
      (let ((temp test))
        (if temp (result temp))))
-    ((cond "iter" (test => result) clause1 clause2 ...)
+    ((cond (test => result) clause1 clause2 ...)
      (let ((temp test))
        (if temp
            (result temp)
-           (cond "iter" clause1 clause2 ...))))
-    ((cond "iter" (test)) test)
-    ((cond "iter" (test) clause1 clause2 ...)
+           (cond clause1 clause2 ...))))
+    ((cond (test)) test)
+    ((cond (test) clause1 clause2 ...)
      (let ((temp test))
        (if temp
            temp
-           (cond "iter" clause1 clause2 ...))))
-    ((cond "iter" (test result1 result2 ...))
+           (cond clause1 clause2 ...))))
+    ((cond (test result1 result2 ...))
      (if test (let () result1 result2 ...)))
-    ((cond "iter" (test result1 result2 ...)
+    ((cond (test result1 result2 ...)
            clause1 clause2 ...)
      (if test
          (let () result1 result2 ...)
-         (cond "iter" clause1 clause2 ...)))
-    ((cond clauses ...)
-     (delay-force (cond "iter" clauses ...)))))
+         (cond clause1 clause2 ...)))))
 
 (define-syntax case
-  ;; TODO: fix with delay-force
   (syntax-rules (else =>)
-    ((case (key ...) clauses ...)
-     (let ((atom-key (key ...)))
-       (case atom-key clauses ...)))
+    ((_ (key ...) clauses ...)
+     (let ((tmp (key ...)))
+       (case tmp clauses ...)))
     ((case key (else => result))
      (result key))
     ((case key (else result1 result2 ...))
      (let () result1 result2 ...))
     ((case key ((atoms ...) result1 result2 ...))
-     (if (memv key '(atoms ...))
-         (let () result1 result2 ...)))
-    ((case key
-       ((atoms ...) => result))
-     (if (memv key '(atoms ...))
-         (result key)))
-    ((case key
-       ((atoms ...) => result)
+     (when (memv key '(atoms ...))
+       result1 result2 ...))
+    ((case key ((atoms ...) => result))
+     (when (memv key '(atoms ...))
+       (result key)))
+    ((case key ((atoms ...) => result)
        clause clauses ...)
      (if (memv key '(atoms ...))
          (result key)
          (case key clause clauses ...)))
-    ((case key
-       ((atoms ...) result1 result2 ...)
+    ((case key ((atoms ...) result1 result2 ...)
        clause clauses ...)
      (if (memv key '(atoms ...))
          (let () result1 result2 ...)
@@ -71,11 +81,20 @@
 
 (define-syntax and
   (syntax-rules ()
-    ((and x ...) (delay-force (r7rs:and (! x) ...)))))
+    ((_) #t)
+    ((_ x) x)
+    ((_ x y ...)
+     (if (! x) (and y ...) #f))))
 
 (define-syntax or
   (syntax-rules ()
-    ((or x ...) (delay-force (r7rs:or (! x) ...)))))
+    ((_) #f)
+    ((_ x) x)
+    ((_ x y ...)
+     (let ((tmp x))
+       (if (! tmp)
+           tmp
+           (or y ...))))))
 
 (define-syntax when
   (syntax-rules ()
@@ -87,57 +106,90 @@
 
 (define-syntax define-record-type
   (syntax-rules ()
-    ((_ name (cstr field ...) predicate (field accessor) ...)
+    ((_ name (cstr etc ...) predicate (field accessor) ...)
      (define-record-type "tmps" name
-       (cstr cstr-tmp)
+       (cstr (cstr-tmp etc ...))
        (predicate predicate-tmp)
        ()
        ((field accessor) ...)))
     ((_ "tmps" name _c _? (tmps ...) ((field accessor) rest ...))
      (define-record-type "tmps" name _c _? ((tmp field accessor) tmps ...) (rest ...)))
-    ((_ "tmps" name (cstr cstr-tmp) (predicate predicate-tmp)
+    ((_ "tmps" name (cstr (cstr-tmp etc ...)) (predicate predicate-tmp)
         ((accessor-tmp field accessor) ...) ())
-     (r7rs:begin
-      (r7rs:define-record-type name
-                               (cstr-tmp field ...)
-                               predicate-tmp
-                               (field accessor-tmp) ...)
-      (define-wrappers-for-lazy ((cstr field ...) cstr-tmp))
-      (define-wrappers-from-strict
-          ;; Record type
-        ((predicate x) predicate-tmp)
-        ((accessor x) accessor-tmp) ...)))))
-
-(define (apply proc . arguments) (r7rs:apply r7rs:apply (! proc) arguments))
+     (r7rs:define-values (cstr predicate accessor ...)
+       (let ()
+         (r7rs:define-record-type name
+                                  (cstr-tmp etc ...)
+                                  predicate-tmp
+                                  (field accessor-tmp) ...)
+         (define-wrappers-for-lazy ((cstr field ...) cstr-tmp))
+         (define-wrappers-from-strict
+             ;; Record type
+           ((predicate x) predicate-tmp)
+           ((accessor x) accessor-tmp) ...)
+         (r7rs:values cstr predicate accessor ...))))))
+
+(define (apply proc . arguments)
+  (if (null? arguments)
+      (! proc)
+      (r7rs:apply (! proc)
+                  (r7rs:let loop ((arguments arguments))
+                            (r7rs:if (r7rs:null? (r7rs:cdr arguments))
+                                     (!list (r7rs:car arguments))
+                                     (r7rs:cons (r7rs:car arguments)
+                                                (loop (r7rs:cdr arguments))))))))
 
 (define (error message . irritants)
-  (r7rs:apply r7rs:error message irritants))
+  (r7rs:apply r7rs:error (! message) irritants))
 
 (r7rs:define (!list list)
-             (let loop ((list (! list))
-                        (acc '()))
-               (if (null? list)
-                   (reverse acc)
-                   (loop (! (cdr list)) (cons (car list) acc)))))
-
-;;; Equivalence procedures
+             (r7rs:let loop ((list (! list))
+                             (acc '()))
+                       (r7rs:if (r7rs:null? list)
+                                (r7rs:reverse acc)
+                                (loop (! (r7rs:cdr list))
+                                      (r7rs:cons (r7rs:car list) acc)))))
 
 (define (floor/ x y)
   (r7rs:let-values (((r1 r2) (r7rs:floor/ (! x) (! y))))
-                   (r7rs:list x y)))
+                   (r7rs:list r1 r2)))
 (define (truncate/ x y)
   (r7rs:let-values (((r1 r2) (r7rs:truncate/ (! x) (! y))))
-                   (r7rs:list x y)))
+                   (r7rs:list r1 r2)))
 
-(define (exact-integer-sqrt x y)
+(define (exact-integer-sqrt x)
   (r7rs:let-values (((r1 r2) (r7rs:exact-integer-sqrt (! x))))
                    (r7rs:list r1 r2)))
 
+(define (equal? x y)
+  (or (eqv? x y)
+      (and (number? x) (number? y)
+           (= x y))
+      (and (pair? x) (pair? y)
+           (equal? (car x) (car y))
+           (equal? (cdr x) (cdr y)))
+      (and (vector? x) (vector? y)
+           (= (vector-length x) (vector-length y))
+           (let loop ((i 0))
+             (cond
+               ((= i (vector-length x)) #t)
+               ((equal? (vector-ref x i) (vector-ref y i))
+                (loop (+ i 1)))
+               (else #f))))
+      (and (string? x) (string? y) (string=? x y))
+      (and (bytevector? x) (bytevector? y)
+           (= (bytevector-length x) (bytevector-length y))
+           (let loop ((i 0))
+             (cond
+               ((= i (bytevector-length x)) #t)
+               ((= (bytevector-u8-ref x) (bytevector-u8-ref y))
+                (loop (+ i 1)))
+               (else #f))))))
+
 (define-wrappers-from-strict
     ;; Equivalence procedures
   ((eq? x y) r7rs:eq?)
   ((eqv? x y) r7rs:eqv?)
-  ((equal? x y) r7rs:equal?)
   ;; Numbers
   ((number? x) r7rs:number?)
   ((complex? x) r7rs:complex?)
@@ -222,6 +274,7 @@
   ((bytevector-length x) r7rs:bytevector-length)
   (bytevector-copy r7rs:bytevector-copy)
   (bytevector-append r7rs:bytevector-append)
+  ((bytevector-u8-ref bv x) r7rs:bytevector-u8-ref)
   (utf8->string r7rs:utf8->string)
   (string->utf8 r7rs:string->utf8)
   ;; Control feature
@@ -258,8 +311,7 @@
   (string<? r7rs:string<?)
   (string<=? r7rs:string<=?)
   (string>? r7rs:string>?)
-  (string>=? r7rs:string>=?)
-  (vector-map r7rs:vector-map))
+  (string>=? r7rs:string>=?))
 
 (define-wrappers-for-lazy
     ;;; Lists and pairs
@@ -301,7 +353,7 @@
     (cond
       ((pair? list) (loop (cdr list) (! (+ i 1))))
       ((null? list) i)
-      (else (error "not a list" list)))))
+      (else #f))))
 
 (define append
   (case-lambda
@@ -339,8 +391,7 @@
     ((obj list equal?)
      (let loop ((list list))
        (cond
-         ((null? list) #f)
-         ((not (pair? list) (error "not a pair" list)))
+         ((not (pair? list)) #f)
          ((equal? (car list) obj) list)
          (else (loop (cdr list))))))))
 
@@ -353,8 +404,7 @@
     ((obj list equal?)
      (let loop ((list list))
        (cond
-         ((null? list) #f)
-         ((not (pair? list) (error "not a pair" list)))
+         ((not (pair? list)) #f)
          ((equal? (caar list) obj) (car list))
          (else (loop (cdr list))))))))
 
@@ -395,3 +445,22 @@
 (define (list->vector list)
   (r7rs:list->vector (!list list)))
 
+(define (vector-map proc x1 . x-rest)
+  (define (ok? i vectors)
+    (or (null? vectors)
+        (and (< i (vector-length (car vectors)))
+             (ok? i (cdr vectors)))))
+  (define vectors (cons x1 x-rest))
+  (list->vector
+   (let loop ((i 0))
+     (if (not (ok? i vectors))
+         '()
+         (cons (apply proc (map (lambda (x) (vector-ref x i))
+                                vectors))
+               (loop (+ i 1)))))))
+
+(define (list-copy x)
+  (if (pair? x)
+      (cons (car x) (list-copy (cdr x)))
+      x))
+
diff --git a/lib/hascheme/base.sld b/lib/hascheme/base.sld
index cefc26d..badb119 100644
--- a/lib/hascheme/base.sld
+++ b/lib/hascheme/base.sld
@@ -1,19 +1,21 @@
 (define-library (hascheme base)
   (import (prefix (except (scheme base)
                           quote define-syntax syntax-rules
-                          let* letrec letrec*)
+                          let-syntax letrec-syntax
+                          let* letrec letrec* ... _)
                   r7rs:)
           (only (scheme base) define-syntax syntax-rules quote
-                let* letrec letrec*)
-          (scheme lazy)
+                let* letrec letrec* ... _ let-syntax letrec-syntax)
+          (hascheme implementation-support)
           (rename (hascheme prelude)
                   (hs:lambda lambda)
                   (hs:define define))
           (hascheme eager)
           (hascheme case-lambda))
-  (export lambda define let let* letrec letrec*
+  (export lambda define let let* letrec letrec* do
           if or and when unless cond case
           define-record-type
+          quote
           seq
           ;; equivalent procedures
           eq? eqv? equal?
@@ -35,6 +37,7 @@
           list-tail list-ref
           member memq memv
           assoc assq assv
+          list-copy
           ;; symbols
           symbol? symbol=? symbol->string string->symbol
           ;; chars
@@ -49,12 +52,17 @@
           vector-copy vector-append vector make-vector list->vector
           ;; bytevectors
           bytevector? make-bytevector bytevector bytevector-length
+          bytevector-u8-ref
           bytevector-copy bytevector-append utf8->string string->utf8
           ;; control features
           procedure? string-map apply map
           ;; exceptions
           error error-object? error-object-message error-object-irritants
           read-error? file-error?
+          vector-map
           ;; Ports
           eof-object eof-object?)
+  (cond-expand
+    ((not chicken) (export _ ... =>))
+    (else))
   (include "base.scm"))
\ No newline at end of file
diff --git a/lib/hascheme/case-lambda.sld b/lib/hascheme/case-lambda.sld
index 74646d7..b1b765c 100644
--- a/lib/hascheme/case-lambda.sld
+++ b/lib/hascheme/case-lambda.sld
@@ -1,5 +1,6 @@
 (define-library (hascheme case-lambda)
   (import (scheme base) (hascheme eager)
+          (hascheme implementation-support)
           (prefix (scheme case-lambda) r7rs:))
   (export case-lambda)
   (begin
diff --git a/lib/hascheme/cxr.sld b/lib/hascheme/cxr.sld
index 9435689..4c44901 100644
--- a/lib/hascheme/cxr.sld
+++ b/lib/hascheme/cxr.sld
@@ -1,8 +1,17 @@
 (define-library (hascheme cxr)
   (import (hascheme base))
-  (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+  (export caaar caadr cadar caddr cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
           cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
   (begin
+    (define (caaar x) (car (car (car x))))
+    (define (caadr x) (car (car (cdr x))))
+    (define (cadar x) (car (cdr (car x))))
+    (define (caddr x) (car (cdr (cdr x))))
+    (define (cdaar x) (cdr (car (car x))))
+    (define (cdadr x) (cdr (car (cdr x))))
+    (define (cddar x) (cdr (cdr (car x))))
+    (define (cdddr x) (cdr (cdr (cdr x))))
     (define (caaaar x) (car (car (car (car x)))))
     (define (caaadr x) (car (car (car (cdr x)))))
     (define (caadar x) (car (car (cdr (car x)))))
diff --git a/lib/hascheme/eager.sld b/lib/hascheme/eager.sld
index 91b0ade..d3ae3bd 100644
--- a/lib/hascheme/eager.sld
+++ b/lib/hascheme/eager.sld
@@ -1,5 +1,6 @@
 (define-library (hascheme eager)
-  (import (scheme base) (scheme lazy) (scheme case-lambda)
+  (import (scheme base) (scheme case-lambda)
+          (hascheme implementation-support)
           (hascheme prelude))
   (export define-wrappers-from-strict
           define-wrappers-for-lazy
@@ -45,10 +46,14 @@
                      #f)))))
            (define-binary-wrapper rest ...)))
         ((_) (begin))))
-    (define seq
-      (case-lambda
-        ((x) x)
-        ((x . y) (delay-force (begin (! x) (apply seq y))))))
+    (define (seq x . rest)
+      (delay-force
+       (let loop ((x x) (rest rest))
+         (if (null? rest)
+             x
+             (begin
+               (! x)
+               (loop (car rest) (cdr rest)))))))
     (define-syntax let*!
       (syntax-rules ()
         ((_ ((formal expr) ...) body ...)
diff --git a/lib/hascheme/implementation-support.sld b/lib/hascheme/implementation-support.sld
new file mode 100644
index 0000000..1b506eb
--- /dev/null
+++ b/lib/hascheme/implementation-support.sld
@@ -0,0 +1,85 @@
+#| Slightly modified from:
+
+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.
+|#
+
+(define-library (hascheme implementation-support)
+  (import (scheme base))
+  (cond-expand
+    ((or chicken gauche)
+     (import (scheme lazy))
+     (export delay force delay-force make-promise promise?))
+    (else
+     (export delay force delay-force make-promise promise?)
+     (begin
+       (define-record-type <promise>
+         (%make-promise cmd)
+         promise?
+         (cmd promise-cmd set-promise-cmd!))
+       (define (make-promise data)
+         (if (promise? data)
+             data
+             (%make-promise (cmd #t data))))
+       (define-record-type <cmd>
+         (cmd eager? thunk)
+         cmd?
+         (eager? cmd-eager? set-cmd-eager!)
+         (thunk cmd-thunk set-cmd-thunk!))
+       (define-syntax delay
+         (syntax-rules ()
+           ((_ exp) (delay-force (%make-promise (cmd #t exp))))))
+       (define-syntax delay-force
+         (syntax-rules () ((_ exp) (%make-promise (cmd #f (lambda () exp))))))
+       (define (force promise)
+         ;; The main driving loop.
+         ;; 
+         ;; Forcing a non-promise just returns a promise.
+         ;; Forcing a "delay" will run the thunk, store the returned value
+         ;; in the promise, and return the value.
+         ;; Forcing a "delay-force" will run the thunk, and then
+         ;;  
+         ;; 1. If the value is not a promise, store the retuend value and
+         ;;    return the value.
+         ;; 2. If the value is a promise, then the first promise becomes
+         ;;    the returned promise. This is done by copying the state of
+         ;;    the second promise into the first, and then *replacing* the
+         ;;    mutatable state of the second promise with the first
+         ;;    promise. The promise is then forced again, tail-recursively.
+         (cond
+           ((cmd? promise) (error 'force "internal error" promise))
+           ((not (promise? promise)) promise)
+           (else
+            (let ((cmd (promise-cmd promise)))
+              (if (cmd-eager? cmd)
+                  (cmd-thunk cmd)
+                  (let* ((promise* ((cmd-thunk cmd)))
+                         (cmd (promise-cmd promise)))
+                    (if (not (promise? promise*))
+                        (begin
+                          (set-cmd-eager! cmd #t)
+                          (set-cmd-thunk! cmd promise*)
+                          promise*)
+                        (let* ((cmd* (promise-cmd promise*)))
+                          (unless (cmd-eager? cmd)
+                            (set-cmd-eager! cmd (cmd-eager? cmd*))
+                            (set-cmd-thunk! cmd (cmd-thunk cmd*))
+                            (set-promise-cmd! promise* cmd))
+                          (force promise*)))))))))))))
\ No newline at end of file
diff --git a/lib/hascheme/lists.scm b/lib/hascheme/lists.scm
new file mode 100644
index 0000000..1fb41e0
--- /dev/null
+++ b/lib/hascheme/lists.scm
@@ -0,0 +1,373 @@
+;;; TODO: Provably infinite lists.
+;;; 
+;;; Provable infinities are distinct data types than cons cells that can
+;;; still be car and cdr'd, along with all of the other operations. A
+;;; provably infinite pair is a list that is append to itself forever,
+;;; except that unlike truly infinite lists (like the naturals), it is
+;;; marked as infinite.
+;;; 
+;;; This should probably be in a separate library.
+
+;;; Constructors
+
+(define (xcons x y) (cons y x))
+
+(define cons*
+  (case-lambda
+    ((x) x)
+    ((x y . rest) (cons x (apply cons* y rest)))))
+
+(define (list-tabulate n init-proc)
+  (unless (and (number? n)
+               (or (= n +inf.0)
+                   (and (positive? n) (exact-integer? n))))
+    (error "invalid list-tabulate length" n))
+  (let loop ((i 0))
+    (if (= i n)
+        '()
+        (cons (init-proc i) (loop (+ i 1))))))
+
+(define (circular-list first . elements)
+  (define total (cons first elements))
+  (let loop ((elements total))
+    (if (null? elements)
+        (loop total)
+        (cons (car elements) (loop (cdr elements))))))
+
+(define iota
+  (case-lambda
+    ((count) (iota count 0))
+    ((count start) (iota count start 1))
+    ((count start step)
+     (unless (and (number? count) (number? start) (number? step)
+                  (or (= +inf.0 count)
+                      (positive? count) (exact-integer? count))
+                  (positive? start) (exact-integer? start)
+                  (positive? step) (exact-integer? step))
+       (error "invalid arguments" count start step))
+     (let loop ((i 0) (el start))
+       (if (= i count)
+           '()
+           (cons el (loop (+ i 1)
+                          (! (+ el step)))))))))
+
+;;; Predicates
+
+(define (not-pair? x) (not (pair? x)))
+(define null-list? list?)
+(define proper-list? list?)
+(define (dotted-list? x)
+  (or (not-pair? x) (and (pair? x) (dotted-list? (cdr x)))))
+
+(define list=
+  (case-lambda
+    ((=) #t)
+    ((= l1) #t)
+    ((= l1 l2)
+     (cond
+       ((and (null? l1) (null? l2)) #t)
+       ((not (and (pair? l1) (pair? l2))) #f)
+       ((= (car l1) (car l2))
+        => (lambda (res)
+             (if (and (null? (cdr l1) (cdr l2)))
+                 res
+                 (list= (cdr l1) (cdr l2)))))
+       (else #f)))
+    ((= l1 l2 . l-rest)
+     (and (list= l1 l2)
+          (apply list= l2 l-rest)))))
+
+;;; Selectors
+
+(define first car)
+(define second cadr)
+(define (third x) (list-ref x 3))
+(define (fourth x) (list-ref x 4))
+(define (fifth x) (list-ref x 5))
+(define (sixth x) (list-ref x 6))
+(define (seventh x) (list-ref x 7))
+(define (eighth x) (list-ref x 8))
+(define (ninth x) (list-ref x 9))
+(define (tenth x) (list-ref x 10))
+
+(define (take x i)
+  (unless (and (exact-integer? i) (>= i 0))
+    (error "invalid number" i))
+  (let loop ((x x) (i i))
+    (cond
+      ((zero? i) '())
+      ((null? x) (error "list too short" x))
+      (else (cons (car x) (loop (cdr x) (- i 1)))))))
+
+(define drop list-tail)
+
+(define (take-right x i) (drop x (- (length x) i)))
+(define (drop-right x i) (take x (- (length x) i)))
+(define drop-right! drop-right)
+
+(define (last x) (car (last-pair x)))
+(define (last-pair x) (take-right x 1))
+
+(define (split-at x i) (list (take x i) (drop x i)))
+(define split-at! split-at)
+
+;;; Misc
+
+(define (length>=? list n)
+  (let loop ((list list) (n n))
+    (cond
+      ((not (positive? n)) #t)
+      ((not-pair? list) #f)
+      (else (length>=? (cdr list) (- n 1))))))
+
+(define (length>? list n)
+  (and (not (= n +inf.0))
+       (length>=? list (+ n 1))))
+
+(define (length<=? list n)
+  (or (= n +inf.0)
+      (let loop ((list list) (n n))
+        (and (not (negative? n))
+             (or (not-pair? list)
+                 (length<=? (cdr list) (- n 1)))))))
+
+(define (length<? list n)
+  (or (= n +inf.0)
+      (length<=? list (- n 1))))
+
+(define (length=? list n)
+  (and (length>=? list n) (length<=? list n)))
+
+(define (concatenate ll)
+  (let loop ((ll ll))
+    (cond
+      ((null? ll) ll)
+      ((not-pair? ll) (error "not a proper list of lists" ll))
+      ((null? (cdr ll)) (car ll))
+      (else (let loop* ((x (car ll)))
+              (cond
+                ((null? x) (loop (cdr ll)))
+                ((not-pair? x) (error "not a proper list" x))
+                (else (cons (car x) (loop* (cdr x))))))))))
+(define concatenate! concatenate)
+(define append! append)
+(define reverse! reverse)
+
+(define (append-reverse rev-head tail)
+  (append (reverse rev-head) tail))
+(define append-reverse! append-reverse)
+
+(define (zip . lists) (apply map list lists))
+(define (unzip lists)
+  (if (any null? lists)
+      '()
+      (cons (map car lists) (unzip (map cdr lists)))))
+
+(define (count pred l1 . lists)
+  (let loop ((lists (cons l1 lists))
+             (count 0))
+    (cond
+      ((any null? lists) count)
+      ((apply pred lists) (loop (map cdr lists)
+                                (! (+ count 1))))
+      (else (loop (map cdr lists) count)))))
+
+;;; Fold, unfold, and map
+
+(define (%fold eager? kons knil . lists)
+  (cond
+    ((any null? lists) knil)
+    (else (%fold eager? kons
+                 (apply kons (append (map car lists)
+                                     (list (if eager?
+                                               (! knil)
+                                               knil))))
+                 (map cdr lists)))))
+
+(define (fold kons knil . lists)
+  (apply %fold #f kons knil lists))
+
+(define (fold! kons knil . lists)
+  (apply %fold #t kons knil lists))
+
+(define (fold-right kons knil . lists)
+  (cond
+    ((any null? lists) knil)
+    (else (apply kons
+                 (append (map car lists)
+                         (list (apply fold-right
+                                      kons
+                                      knil
+                                      (map cdr lists))))))))
+
+(define (reduce f ridentity list)
+  (if (null? list)
+      ridentity
+      (fold f (car list) (cdr list))))
+
+(define (reduce! f ridentity list)
+  (if (null? list)
+      ridentity
+      (fold! f (car list) (cdr list))))
+
+(define (reduce-right f ridentity list)
+  (cond
+    ((null? list) ridentity)
+    ((length=? list 1) (list-ref list 0))
+    (else (fold-right f (car list) (cdr list)))))
+
+(define unfold
+  (case-lambda
+    ((p f g seed) (unfold p f seed (lambda (x) '())))
+    ((p f g seed tail-gen)
+     (if (p seed)
+         (tail-gen seed)
+         (cons (f seed) (unfold p f g (g seed) tail-gen))))))
+
+(define unfold-right
+  (case-lambda
+    ((p f g seed) (unfold-right p f g seed '()))
+    ((p f g seed tail)
+     (let lp ((seed seed) (lis tail))
+       (if (p seed)
+           lis
+           (lp (g seed) (! (cons (f seed) lis))))))))
+
+(define (append-map f . lists)
+  (apply append (apply map f lists)))
+(define append-map! append-map)
+
+(define (filter-map f . lists)
+  (filter (lambda (x) x) (apply map f lists)))
+
+;;; Filtering and partitioning
+
+(define (filter pred x)
+  (cond
+    ((and (pair? x) (pred (car x)))
+     (cons (car x) (filter pred (cdr x))))
+    ((pair? x) (filter pred (cdr x)))
+    (else x)))
+(define filter! filter)
+
+(define (remove pred x) (filter (lambda (x) (not (pred x))) x))
+(define remove! remove)
+
+
+(define (partition pred list)
+  (list (filter pred list) (filter (lambda (x) (not (pred x))) list)))
+(define partition! partition)
+
+(define (find pred list)
+  (cond
+    ((not-pair? list) #f)
+    ((pred (car list)) (car list))
+    (else (find pred (cdr list)))))
+
+(define (find-tail pred list)
+  (cond
+    ((not-pair? list) #f)
+    ((pred (car list)) list)
+    (else (find-tail pred (cdr list)))))
+
+(define (take-while pred list)
+  (cond
+    ((not-pair? list) '())
+    ((pred (car list))
+     (cons (car list) (take-while pred (cdr list))))
+    (else (take-while pred (cdr list)))))
+(define take-while! take-while)
+
+(define (drop-while pred list)
+  (cond
+    ((not-pair? list) list)
+    ((pred (car list)) (drop-while pred (cdr list)))
+    (else list)))
+
+(define (span pred x)
+  (list (take-while pred x) (drop-while pred x)))
+(define span! span)
+(define (break pred x) (span (lambda (x) (not (pred x))) x))
+(define break! break)
+
+(define (any-null? lists)
+  (cond
+    ((null? lists) #f)
+    ((null? (car lists)) #t)
+    (else (any-null? (cdr lists)))))
+
+(define (any pred . lists)
+  (let loop ((lists lists))
+    (and (not (any-null? lists))
+         (or (apply pred (map car lists))
+             (loop (map cdr lists))))))
+
+(define (every pred . lists)
+  (let loop ((lists lists))
+    (or (any null? lists)
+        (let ((value (apply pred (map car lists)))
+              (next (map cdr lists)))
+          (if (any null? next)
+              value
+              (loop next))))))
+
+(define (list-index pred . lists)
+  (let loop ((lists lists)
+             (i 0))
+    (and (not (any null? lists))
+         (if (apply pred (map car lists))
+             i
+             (loop (map cdr lists) (! (+ i 1)))))))
+
+(define delete
+  (case-lambda
+    ((x list) (delete x list equal?))
+    ((x list =) (remove (lambda (y) (= x y)) list))))
+(define delete! delete)
+
+(define delete-duplicates
+  (case-lambda
+    ((list) (delete-duplicates list equal?))
+    ((list =)
+     (let loop ((list list) (found '()))
+       (cond
+         ((not-pair? list) list)
+         ((member (car list) found equal?)
+          (loop (cdr list) found))
+         (else (cons (car list)
+                     (loop (cdr list) (cons (car list) found)))))))))
+(define delete-duplicates! delete-duplicates)
+
+(define (list-set list n val)
+  (unless (and (exact-integer? n) (not (negative? n)))
+    (error "not a non-negative exact integer" n))
+  (let loop ((list list) (n n))
+    (cond
+      ((not-pair? list) (error "list truncated" list n val))
+      ((zero? n) (cons val (cdr list)))
+      (else (cons (car list) (loop (cdr list) (- n 1)))))))
+
+(define map! map)
+
+(define (alist-cons k v a) (cons (cons k v) a))
+(define (alist-copy x)
+  (if (null? x)
+      x
+      (cons (cons (caar x) (cdar x)) (alist-copy (cdr x)))))
+
+(define alist-delete
+  (case-lambda
+    ((k a) (alist-delete k a equal?))
+    ((k a =)
+     (if (null? a)
+         a
+         (let ((key2 (caar a)))
+           (if (= k key2)
+               (cons (car a) (alist-delete k (cdr a) =))
+               (alist-delete k (cdr a) =)))))))
+
+(define alist-delete! alist-delete)
+
+(define (list-iterate proc base)
+  (let ((new (proc (! base))))
+    (cons new (list-iterate proc new))))
diff --git a/lib/hascheme/lists.sld b/lib/hascheme/lists.sld
new file mode 100644
index 0000000..ba9490b
--- /dev/null
+++ b/lib/hascheme/lists.sld
@@ -0,0 +1,29 @@
+(define-library (hascheme lists)
+  (import (hascheme base) (hascheme case-lambda) (hascheme cxr) (hascheme eager))
+  (export cons list xcons cons* make-list list-tabulate circular-list iota
+          list-copy
+          pair? null? proper-list? dotted-list? null-list? not-pair? list=
+          car cdr
+          cadr caar cddr cdar
+          caaar caadr cadar caddr cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+          cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+          first second third fourth fifth sixth seventh eighth ninth tenth
+          list-ref take drop take-right drop-right drop-right!
+          split-at split-at! last last-pair
+          length length>=? length>? length<? length<=? length=?
+          append append! concatenate concatenate! reverse reverse!
+          append-reverse append-reverse!
+          zip unzip count
+          fold fold! fold-right reduce reduce!
+          unfold unfold-right append-map append-map! filter-map
+          map map!
+          filter remove partition
+          filter! remove! partition!
+          find find-tail take-while take-while! drop-while span break
+          span! break!
+          any every list-index member memv memq
+          delete delete-duplicates
+          delete! delete-duplicates!
+          assoc assq assv alist-cons alist-copy alist-delete alist-delete!)
+  (include "lists.scm"))
\ No newline at end of file
diff --git a/lib/hascheme/prelude.sld b/lib/hascheme/prelude.sld
index e532ab5..61a65e0 100644
--- a/lib/hascheme/prelude.sld
+++ b/lib/hascheme/prelude.sld
@@ -1,12 +1,11 @@
 (define-library (hascheme prelude)
-  (import (scheme base) (scheme lazy))
+  (import (scheme base) (hascheme implementation-support))
   (export hs:lambda hs:define)
   (begin
     (define-syntax hs:lambda
       (syntax-rules ()
         ((_ formal body ...)
-         (lambda formal (delay-force (let ()
-                                       (seq body ...)))))))
+         (lambda formal (delay-force (let () body ...))))))
     (define-syntax hs:define
       (syntax-rules ()
         ((_ (name . formals) body ...)
diff --git a/lib/hascheme/support.sld b/lib/hascheme/support.sld
new file mode 100644
index 0000000..99d9a58
--- /dev/null
+++ b/lib/hascheme/support.sld
@@ -0,0 +1,24 @@
+(define-library (hascheme support)
+  (import (scheme base) (hascheme implementation-support))
+  (export user-defined-forcers recursive-force)
+  (begin
+    (define user-defined-forcers
+      (make-parameter
+       (list (cons procedure?
+                   (lambda (x)
+                     (lambda args
+                       (recursive-force (apply x args))))))))
+    (define (find-user-defined-forcer x)
+      (let loop ((forcers (user-defined-forcers)))
+        (cond
+          ((null? forcers) #f)
+          (((caar forcers) x) (cdar forcers))
+          (else (loop (cdr forcers))))))
+    (define (recursive-force x)
+      (let ((x (force x)))
+        (cond
+          ((pair? x) (cons (recursive-force (car x))
+                           (recursive-force (cdr x))))
+          ((vector? x) (vector-map recursive-force x))
+          ((find-user-defined-forcer x) => (lambda (forcer) (forcer x)))
+          (else x))))))
\ No newline at end of file
diff --git a/lib/tests/hascheme/base.sld b/lib/tests/hascheme/base.sld
new file mode 100644
index 0000000..4ce4c79
--- /dev/null
+++ b/lib/tests/hascheme/base.sld
@@ -0,0 +1,825 @@
+(define-library (tests hascheme base)
+  (import (scheme base)
+          (hascheme implementation-support)
+          (hascheme support)
+          (prefix (hascheme base) h:))
+  (cond-expand
+    (chicken (import (srfi 64) (chicken condition)))
+    (chibi (import (except (chibi test) test test-equal)
+                   (rename (only (chibi test) test) (test test-equal))))
+    (else (import (srfi 64))))
+  (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 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-assert 5 count)
+          (test-assert 0 (force p))
+          (test-assert 10 count))))
+    (define (test-preliminaries)
+      (test-assert "promises are a distinct type"
+        (let ((x (make-promise #t)))
+          (and (not (or (procedure? x)
+                        (pair? x)
+                        (vector? x)))
+               (promise? x))))
+      (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