fix new lazy implementation

4 files changed, 241 insertions, 114 deletions

diff --git a/lib/hascheme/case-lambda.sld b/lib/hascheme/case-lambda.sld
index f3918d1..cca9d42 100644
--- a/lib/hascheme/case-lambda.sld
+++ b/lib/hascheme/case-lambda.sld
@@ -7,4 +7,4 @@
     (define-syntax case-lambda
       (syntax-rules ()
         ((_ (clause body ...) ...)
-         (r7rs:case-lambda (clause (hs:delay-force (let () body ...))) ...))))))
\ No newline at end of file
+         (r7rs:case-lambda (clause (delay-force (let () body ...))) ...))))))
\ No newline at end of file
diff --git a/lib/hascheme/eager.sld b/lib/hascheme/eager.sld
index 15df4ae..ea9e771 100644
--- a/lib/hascheme/eager.sld
+++ b/lib/hascheme/eager.sld
@@ -1,10 +1,6 @@
 (define-library (hascheme eager)
   (import (scheme base) (scheme case-lambda)
-          (rename (hascheme prelude)
-                  (hs:delay delay)
-                  (hs:force force)
-                  (hs:delay-force delay-force)
-                  (hs:promise? promise?)))
+          (hascheme prelude))
   (export define-wrappers-from-strict
           define-wrappers-for-lazy
           define-binary-wrapper
diff --git a/lib/hascheme/prelude.sld b/lib/hascheme/prelude.sld
index e9ef1d9..d4b632f 100644
--- a/lib/hascheme/prelude.sld
+++ b/lib/hascheme/prelude.sld
@@ -26,58 +26,61 @@
       shared-promise?
       (done? shared-promise-done? set-shared-promise-done!)
       (data shared-promise-data set-shared-promise-data!))
-    (define (make-callable-promise done? thunk)
-      (let ((promise (promise-wrapper (shared-promise done? thunk))))
-        (%hascheme-promise promise
-                           (lambda subformals
-                             (make-callable-promise
-                              (delay-force
-                                (let ((resolved (%force promise)))
-                                  (apply resolved subformals))))))))
     (define-syntax delay-force
       (syntax-rules ()
         ((_ expr)
          (make-callable-promise #f (lambda () expr)))))
+    (define (make-callable-promise done? data)
+      (letrec ((this
+                (%hascheme-promise (promise-wrapper
+                                    (shared-promise done? data))
+                                   (lambda subformals
+                                     (delay-force
+                                        (let ((resolved (force this)))
+                                          (apply resolved subformals)))))))
+        this))
     (define-syntax delay
       (syntax-rules ()
         ((_ expr)
-         (make-callable-promise #t (lambda () expr)))))
+         (delay-force (make-callable-promise #t expr)))))
     (define-syntax hs:lambda
       (syntax-rules ()
         ((_ formal body ...)
          (delay (lambda formal (delay-force (let () body ...)))))))
     (define (force promise)
-      (if (promise? promise)
+      (if (not (promise? promise))
+          promise
           (let* ((wrapper (get-promise-wrapper promise))
                  (shared (promise-wrapper-box wrapper)))
             (if (shared-promise-done? shared)
                 (shared-promise-data shared)
-                (let ((promise* ((shared-promise-data shared)))
-                      (shared (promise-wrapper-box wrapper)))
+                (let* ((promise* ((shared-promise-data shared)))
+                       (shared (promise-wrapper-box wrapper)))
                   ;; In the R7RS example, the conditional is
                   ;; (unless (promise-done? promise) ...)
+                  ;;
                   ;; The conditional will run when the promise was made
                   ;; by delay-force. The sample implementation does not
                   ;; allow for forcing of non-promises, so this also has
                   ;; to check that the returned value is a promise.
+                  ;;
                   ;; It also has to unbox the wrapper, to make it
                   ;; re-enterant.
                   (unless (shared-promise-done? shared)
                     (if (promise? promise*)
                         (let* ((wrapper* (get-promise-wrapper promise*))
-                               (shared* (promise-wrapper-box wrapper*))
+                               (shared* (promise-wrapper-box wrapper*)))
                           (set-shared-promise-done! shared
                                                     (shared-promise-done?
                                                      shared*))
                           (set-shared-promise-data! shared
                                                     (shared-promise-data
                                                      shared*))
-                          (set-promise-wrapper-box! wrapper* shared)))
+                          (set-promise-wrapper-box! wrapper* shared))
                         (begin
                          (set-shared-promise-done! shared #t)
                          (set-shared-promise-data! shared promise*))))
-                  (force promise))))
-          promise))
+                  (force promise))))))
     (define-syntax hs:define
       (syntax-rules ()
         ((_ (name . formals) body ...)
diff --git a/lib/tests/hascheme/base.sld b/lib/tests/hascheme/base.sld
index 129904b..11b96d7 100644
--- a/lib/tests/hascheme/base.sld
+++ b/lib/tests/hascheme/base.sld
@@ -4,9 +4,8 @@
           (hascheme support)
           (prefix (hascheme base) h:))
   (cond-expand
-    (chicken-5 (import (srfi 64) (chicken condition)))
     (chicken-6 (import (except (test) test test-equal)
-                       (rename (only (test) 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))))
@@ -16,6 +15,8 @@
       (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,12 +54,139 @@
       (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)))
+        (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)))
@@ -67,7 +195,7 @@
                     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)))
@@ -94,13 +222,13 @@
       (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))))
@@ -109,14 +237,14 @@
                          (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)
@@ -126,7 +254,7 @@
                     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)))
@@ -142,52 +270,52 @@
     (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))
@@ -195,33 +323,33 @@
                   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)
@@ -246,11 +374,11 @@
                     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)
@@ -259,9 +387,9 @@
                          (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)
@@ -291,7 +419,7 @@
                             (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))
@@ -315,7 +443,7 @@
                          (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))
@@ -331,7 +459,7 @@
                   (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)
@@ -367,12 +495,12 @@
                         (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))))
@@ -385,9 +513,9 @@
                                  (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))
@@ -453,7 +581,7 @@
                     '(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))))
@@ -461,7 +589,7 @@
       (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)
@@ -570,8 +698,8 @@
     (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)))
@@ -582,10 +710,10 @@
       (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))
@@ -601,7 +729,7 @@
       (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)))
@@ -632,28 +760,28 @@
                   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 ()