hascheme using its own delay-force impl

5 files changed, 87 insertions, 54 deletions

diff --git a/hascheme.egg b/hascheme.egg
index 308fb02..710fe95 100644
--- a/hascheme.egg
+++ b/hascheme.egg
@@ -4,51 +4,40 @@
  (category lang-exts)
  (license "BSD 0-clause")
  (dependencies r7rs srfi-259)
- (test-dependencies srfi-64)
+ (test-dependencies test)
  (components (extension hascheme.base
                (source "lib/hascheme/base.sld")
                (source-dependencies "lib/hascheme/base.scm")
                (component-dependencies hascheme.prelude
                                        hascheme.eager
-                                       hascheme.case-lambda)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+                                       hascheme.case-lambda))
              (extension hascheme.support
                (source "lib/hascheme/support.sld")
-               (component-dependencies hascheme.prelude)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.prelude))
              (extension hascheme.prelude
-               (source "lib/hascheme/prelude.sld")
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (source "lib/hascheme/prelude.sld"))
              (extension hascheme.case-lambda
                (source "lib/hascheme/case-lambda.sld")
-               (component-dependencies hascheme.eager hascheme.prelude)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.eager hascheme.prelude))
              (extension hascheme.eager
                (source "lib/hascheme/eager.sld")
-               (component-dependencies hascheme.prelude)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.prelude))
              (extension hascheme.char
                (source "lib/hascheme/char.sld")
-               (component-dependencies hascheme.base hascheme.eager)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.base hascheme.eager))
              (extension hascheme.complex
                (source "lib/hascheme/complex.sld")
-               (component-dependencies hascheme.base hascheme.eager)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.base hascheme.eager))
              (extension hascheme.control
                (source "lib/hascheme/control.sld")
-               (component-dependencies hascheme.base hascheme.case-lambda)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.base hascheme.case-lambda))
              (extension hascheme.cxr
                (source "lib/hascheme/cxr.sld")
-               (component-dependencies hascheme.base)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.base))
              (extension hascheme.inexact
                (source "lib/hascheme/inexact.sld")
-               (component-dependencies hascheme.base hascheme.eager)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))
+               (component-dependencies hascheme.base hascheme.eager))
              (extension hascheme.lists
                (source "lib/hascheme/lists.sld")
                (source-dependencies "lib/hascheme/lists.scm")
-               (component-dependencies hascheme.base hascheme.case-lambda hascheme.cxr)
-               (csc-options "-R" "r7rs" "-X" "r7rs"))))
+               (component-dependencies hascheme.base hascheme.case-lambda hascheme.cxr))))
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))))
diff --git a/tests/run.scm b/tests/run.scm
index 8933e00..1036295 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,18 +1,14 @@
 (cond-expand
-  (chicken-5 (import r7rs (srfi 64))
+  (chicken-6 (import (test))
              (load "../lib/tests/hascheme/base.sld"))
   (chibi (import (chibi test)))
   (else (import (srfi 64))))
 
-(cond-expand
-  (chicken-5 (test-runner-current (test-runner-create)))
-  (else))
-
 (import (scheme process-context) (tests hascheme base))
 (test-group "base" (test-base))
 
 (cond-expand
-  (chibi (test-exit))
+  ((or chibi chicken-6) (test-exit))
   (else (exit (if (zero? (test-runner-fail-count (test-runner-current)))
                   0
                   1))))