first attempt at moving over to SRFI-259

1 files changed, 91 insertions, 225 deletions

diff --git a/lib/tests/hascheme/base.sld b/lib/tests/hascheme/base.sld
index 4ce4c79..1be93b4 100644
--- a/lib/tests/hascheme/base.sld
+++ b/lib/tests/hascheme/base.sld
@@ -1,6 +1,6 @@
 (define-library (tests hascheme base)
   (import (scheme base)
-          (hascheme implementation-support)
+          (hascheme eager)
           (hascheme support)
           (prefix (hascheme base) h:))
   (cond-expand
@@ -14,8 +14,6 @@
       (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))
@@ -53,144 +51,12 @@
       (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)))
+                   (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)))
@@ -199,7 +65,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                     effect)))
     (define (test-if)
       (test-assert "if returns a promise"
-        (promise? (h:if #t #t #f)))
+                   (promise? (h:if #t #t #f)))
       (test-equal "forcing if runs it"
                   'true
                   (force (h:if #t 'true 'false)))
@@ -226,13 +92,13 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
       (test-equal "let works as normal"
                   5
                   (h:let ((x 5))
-                    x))
+                         x))
       (let ((loop (h:let loop ((x 0))
-                    (if (< x 10)
-                        (loop (+ x 1))
-                        x))))
+                         (if (< x 10)
+                             (loop (+ x 1))
+                             x))))
         (test-assert "named let returns a promise"
-          (promise? loop))
+                     (promise? loop))
         (test-equal "forcing named let runs the promise"
                     10
                     (force loop))))
@@ -241,14 +107,14 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                          (acc 0 (h:+ acc 1)))
                         ((h:null? l) acc))))
         (test-assert "do returns a promise"
-          (promise? loop))
+                     (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)))))
+                         (h:set! effect (+ effect 1)))))
         (test-equal "do has not run yet"
                     0
                     effect)
@@ -258,7 +124,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                     effect)))
     (define (test-seq)
       (test-assert "seq returns a promise"
-        (promise? (h:seq #t #t #t)))
+                   (promise? (h:seq #t #t #t)))
       (test-equal "seq returns its last argument"
                   5
                   (force (h:seq 0 1 2 3 4 5)))
@@ -274,52 +140,52 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     (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)))))
+       (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))))))
+       (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))
+                     (promise? expr))
         (test-equal "and has not run yet"
                     0
                     effect)
         (test-assert "and runs as normal for falses"
-          (not (force expr)))
+                     (not (force expr)))
         (test-equal "and is non-strict"
                     1
                     effect))
@@ -327,33 +193,33 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                   5
                   (force (h:and 1 2 3 4 5)))
       (test-assert "and run as normal for the zero argument case"
-        (h:and)))
+                   (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))
+                     (promise? expr))
         (test-equal "or has not run yet"
                     0
                     effect)
         (test-assert "or runs as normal for truths"
-          (force expr))
+                     (force expr))
         (test-equal "or is non-strict"
                     1
                     effect))
       (test-assert "or runs as normal for falses"
-        (not (force (h:or #f #f))))
+                   (not (force (h:or #f #f))))
       (test-assert "or runs as normal for the zero argument case"
-        (not (force (h:or)))))
+                   (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))
+                     (promise? expr1))
         (test-assert "unless returns a promise"
-          (promise? expr2))
+                     (promise? expr2))
         (test-equal "neither have run yet"
                     0
                     effect)
@@ -378,11 +244,11 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                     effect)))
     (define (test-record-types)
       (h:define-record-type <test>
-        (kons kar kdr kbr)
-        kons?
-        (kar kar)
-        (kdr kdr)
-        (kbr kbr))
+                            (kons kar kdr kbr)
+                            kons?
+                            (kar kar)
+                            (kdr kdr)
+                            (kbr kbr))
       (let* ((effect 0)
              (expr (kons (h:seq (h:set! effect 1)
                                 10)
@@ -391,9 +257,9 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                          (h:seq (h:set! effect 3)
                                 30))))
         (test-assert "constructor returns a promise"
-          (promise? expr))
+                     (promise? expr))
         (test-assert "forcing returns a value that the predicate accepts"
-          (force (kons? expr)))
+                     (force (kons? expr)))
         (test-equal "constructor is not strict in any argument"
                     0
                     effect)
@@ -423,7 +289,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                             (h:seq (h:set! effect2 1) 1)
                             (h:list (h:seq (h:set! effect3 1) 2)))))
         (test-assert "apply returns a promise"
-          (promise? expr))
+                     (promise? expr))
         (test-equal "apply has not run yet"
                     '(0 0 0)
                     (list effect effect2 effect3))
@@ -447,7 +313,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                          (h:seq (h:set! effect2 3)
                                 in2))))
         (test-assert "returns a promise"
-          (promise? expr))
+                     (promise? expr))
         (test-equal "not run yet"
                     '(0 0)
                     (list effect1 effect2))
@@ -463,7 +329,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                   (recursive-force (h:exact-integer-sqrt 5))))
     (define (test-wrappers-from-strict)
       (test-assert "pair?"
-        (force (h:pair? (h:cons 1 2)))))
+                   (force (h:pair? (h:cons 1 2)))))
     (define (test-constructors)
       (test-group "cons"
         (let* ((effect1 0)
@@ -499,12 +365,12 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                         (h:seq (h:set! effect3 1) 0)
                         (h:seq (h:set! effect4 1) 10))))
         (test-assert "< returns a promise"
-          (promise? expr))
+                     (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)))
+                     (not (force expr)))
         (test-equal "< is not necessarily strict"
                     '(1 1 1 0)
                     (list effect1 effect2 effect3 effect4))))
@@ -517,9 +383,9 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                                  (h:vector 4 5 6 (h:seq (h:set! effect2 1)
                                                         7)))))
         (test-assert "vector-map returns a promise"
-          (promise? expr))
+                     (promise? expr))
         (test-assert "vector-map forced returns a vector"
-          (vector? (force expr)))
+                     (vector? (force expr)))
         (test-equal "vector-map is non-strict"
                     '(1 0)
                     (list effect1 effect2))
@@ -585,7 +451,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                     '(0 0)
                     (list effect1 effect2))
         (test-assert "list? works"
-          (force expr))
+                     (force expr))
         (test-equal "list? does not force the values of the list"
                     '(0 1)
                     (list effect1 effect2))))
@@ -593,7 +459,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
       (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)))
+                     (force (h:list? expr)))
         (test-equal "make-list is strict in its first argument"
                     1
                     effect)
@@ -702,8 +568,8 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     (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))))))))
+                                       (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)))
@@ -714,10 +580,10 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
       (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))))))))
+                                      (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))
@@ -733,7 +599,7 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
       (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"))))
+                     (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)))
@@ -764,28 +630,28 @@ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
                   1
                   (force (h:let* ((x 0)
                                   (x (h:+ x 1)))
-                           x)))
+                                 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))))
+                   (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)))))
+                                                  (h:+ 1 (q (h:- x 1)))))
                                      (q (h:lambda (y)
-                                          (h:if (h:zero? y)
-                                                0
-                                                (h:+ 1 (p (h:- y 1))))))
+                                                  (h:if (h:zero? y)
+                                                        0
+                                                        (h:+ 1 (p (h:- y 1))))))
                                      (x (p 5))
                                      (y x))
-                           y))))
+                                    y))))
     #;(define (test-misc-wrapped-procedures)
         (let-syntax ((test-wrapped
                       (syntax-rules ()