hascheme using its own delay-force impl

3 files changed, 73 insertions, 25 deletions

diff --git a/lib/hascheme/cxr.sld b/lib/hascheme/cxr.sld
index 6c14836..4c44901 100644
--- a/lib/hascheme/cxr.sld
+++ b/lib/hascheme/cxr.sld
@@ -1,8 +1,5 @@
 (define-library (hascheme cxr)
-  (import (hascheme base)
-          ;; TODO: Why does this not work in CHICKEN?
-          ;; This fails with a failure to find delay-force.
-          (hascheme eager))
+  (import (hascheme base))
   (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)
diff --git a/lib/hascheme/prelude.sld b/lib/hascheme/prelude.sld
index 5eb4500..e9ef1d9 100644
--- a/lib/hascheme/prelude.sld
+++ b/lib/hascheme/prelude.sld
@@ -1,33 +1,82 @@
+;;;; This library implements the {delay, force, delay-force} expressions
+;;;; as described in the R7RS using SRFI 259 procedure objects.
+;;;;
+;;;; General higher-order procedures are difficult to use in the style
+;;;; of HaScheme expressions, so instead these promise objects are
+;;;; procedures of arbitrary arguments that do not argument check until
+;;;; they are forced.
+;;;;
+;;;; These promises are not disjoint types, but an object is `promise?`
+;;;; iff it was made with `delay`, `delay-force`, or an object that was
+;;;; `promise?`. Hence `promise?` is a sufficiently discerning predicate
+;;;; for practical purposes.
+
 (define-library (hascheme prelude)
-  (import (scheme base) (scheme lazy) (srfi 259))
-  (export hs:lambda hs:define hs:promise?
-          hs:delay hs:delay-force hs:force
-          %get-raw-promise)
+  (import (scheme base) (srfi 259))
+  (export hs:lambda hs:define promise? delay delay-force force)
   (begin
     (define-procedure-tag %hascheme-promise
-      hs:promise? %get-raw-promise)
-    (define (make-callable-promise promise)
-      (%hascheme-promise promise
-                         (lambda subformals
-                           (make-callable-promise
-                            (delay-force
-                             (let ((resolved (force promise)))
-                               (apply resolved subformals)))))))
-    (define-syntax hs:delay-force
+      promise? get-promise-wrapper)
+    (define-record-type <promise-wrapper>
+      (promise-wrapper box)
+      promise-wrapper?
+      (box promise-wrapper-box set-promise-wrapper-box!))
+    (define-record-type <shared-promise>
+      (shared-promise done? data)
+      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 (delay-force expr)))))
-    (define-syntax hs:delay
+         (make-callable-promise #f (lambda () expr)))))
+    (define-syntax delay
       (syntax-rules ()
         ((_ expr)
-         (make-callable-promise (delay expr)))))
+         (make-callable-promise #t (lambda () expr)))))
     (define-syntax hs:lambda
       (syntax-rules ()
         ((_ formal body ...)
-         (hs:delay (lambda formal body ...)))))
-    (define (hs:force promise)
-      (if (hs:promise? promise)
-          (force (%get-raw-promise promise))
+         (delay (lambda formal (delay-force (let () body ...)))))))
+    (define (force promise)
+      (if (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)))
+                  ;; 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*))
+                          (set-shared-promise-done! shared
+                                                    (shared-promise-done?
+                                                     shared*))
+                          (set-shared-promise-data! shared
+                                                    (shared-promise-data
+                                                     shared*))
+                          (set-promise-wrapper-box! wrapper* shared)))
+                        (begin
+                         (set-shared-promise-done! shared #t)
+                         (set-shared-promise-data! shared promise*))))
+                  (force promise))))
           promise))
     (define-syntax hs:define
       (syntax-rules ()
diff --git a/lib/tests/hascheme/base.sld b/lib/tests/hascheme/base.sld
index 1be93b4..129904b 100644
--- a/lib/tests/hascheme/base.sld
+++ b/lib/tests/hascheme/base.sld
@@ -4,7 +4,9 @@
           (hascheme support)
           (prefix (hascheme base) h:))
   (cond-expand
-    (chicken (import (srfi 64) (chicken condition)))
+    (chicken-5 (import (srfi 64) (chicken condition)))
+    (chicken-6 (import (except (test) test test-equal)
+                       (rename (only (test) test) (test test-equal))))
     (chibi (import (except (chibi test) test test-equal)
                    (rename (only (chibi test) test) (test test-equal))))
     (else (import (srfi 64))))