From 12211fff7292a57fb872fd1bb205939a52e996d2 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Thu, 20 May 2010 06:37:24 -0400
Subject: [PATCH] Various lazy-related fixes etc.

* A long-standing bug, which happened with
    (let ([x (lazy (delay 1))]) (force x) (force x))
  not being properly handled.

* Added `delay/strict', mostly for the below.

* Made srfi/45 reprovide it as `eager'.

* Also restricted the exports from srfi/45 to its interface.

All of these issues were reported by Andreas Rottmann.
---
 collects/racket/private/promise.rkt          |  1 +
 collects/racket/promise.rkt                  | 12 +++++++++++-
 collects/scribblings/reference/promise.scrbl |  9 ++++++++-
 collects/srfi/45/lazy.rkt                    |  6 +++++-
 collects/tests/lazy/promise.rkt              | 15 ++++++++++++++-
 5 files changed, 39 insertions(+), 4 deletions(-)

diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt
index 6b6c5bf697..973328be39 100644
--- a/collects/racket/private/promise.rkt
+++ b/collects/racket/private/promise.rkt
@@ -74,6 +74,7 @@
       ;; follow all sharings (and shortcut directly to the right force)
       [(composable-promise? v) (force/composable v)]
       [(null? v) (values)]
+      [(promise? v) (force v)] ; non composable promise is forced as usual
       [else (error 'force "composable promise with invalid contents: ~e" v)])))
 
 ;; convenient utility for any number of stored values or a raised value.
diff --git a/collects/racket/promise.rkt b/collects/racket/promise.rkt
index 0d91e9da98..c83ce1c4e4 100644
--- a/collects/racket/promise.rkt
+++ b/collects/racket/promise.rkt
@@ -7,11 +7,21 @@
 
 (define-struct (promise/name promise) ()
   #:property prop:force (lambda (p) ((pref p))))
-
 (provide (rename-out [delay/name* delay/name]))
 (define delay/name make-promise/name)
 (define-syntax (delay/name* stx) (make-delayer stx #'delay/name '()))
 
+;; mostly to implement srfi-45's `eager'
+(define-struct (promise/strict promise) ()
+  #:property prop:force (lambda (p) (reify-result (pref p)))) ; never a thunk
+(provide (rename-out [delay/strict* delay/strict]))
+(define (delay/strict thunk)
+  ;; could use `reify-result' here to capture exceptions too, or just create a
+  ;; promise and immediately force it, but no point since if there's an
+  ;; exception then the promise value is never used.
+  (make-promise/strict (call-with-values thunk list)))
+(define-syntax (delay/strict* stx) (make-delayer stx #'delay/strict '()))
+
 ;; utility struct
 (define-struct (running-thread running) (thread))
 
diff --git a/collects/scribblings/reference/promise.scrbl b/collects/scribblings/reference/promise.scrbl
index 6960fd06ff..3c01fef4ca 100644
--- a/collects/scribblings/reference/promise.scrbl
+++ b/collects/scribblings/reference/promise.scrbl
@@ -75,12 +75,19 @@ Returns @scheme[#t] if @scheme[promise] is currently being forced.
 Creates a ``call-by-name'' promise that is similar to
 @scheme[delay]-promises, except that the resulting value is not
 cached.  This kind of promise is essentially a thunk that is wrapped
-in a way that @scheme[force] recognizes.  
+in a way that @scheme[force] recognizes.
 
 If a @scheme[delay/name] promise forces itself, no exception is
 raised, the promise is never considered ``running'' or ``forced'' in
 the sense of @scheme[promise-running?] and @scheme[promise-forced?].}
 
+@defform[(delay/strict body ...+)]{
+
+Creates a ``strict'' promise: it is evaluated immediately, and the
+result is wrapped in a promise value.  Note that the body can evaluate
+to multiple values, and forcing the resulting promise will return these
+values.}
+
 @defform[(delay/sync body ...+)]{
 
 Produces a promise where an attempt to @scheme[force] the promise by a
diff --git a/collects/srfi/45/lazy.rkt b/collects/srfi/45/lazy.rkt
index 5cb2fd88ba..ca98e70b39 100644
--- a/collects/srfi/45/lazy.rkt
+++ b/collects/srfi/45/lazy.rkt
@@ -2,7 +2,11 @@
 
 ;; scheme/promise has srfi-45-style primitives
 (require scheme/promise)
-(provide (all-from-out scheme/promise))
+(provide delay lazy force
+         ;; Strictly speaking, this should be a procedure according to srfi-45.
+         ;; It's easy to make it one, but then it loses its ability to deal
+         ;; with multiple values (which the srfi completely ignores).
+         (rename-out [delay/strict eager]))
 
 ;; TODO: there is a small difference between the primitives in srfi-45 and the
 ;; ones provided by scheme/promise (the latter is a bit more permissive).  See
diff --git a/collects/tests/lazy/promise.rkt b/collects/tests/lazy/promise.rkt
index f0c2c903d3..71e347fa9c 100644
--- a/collects/tests/lazy/promise.rkt
+++ b/collects/tests/lazy/promise.rkt
@@ -136,6 +136,15 @@
           (force p) => 3
           x => 3)))
 
+(define (test-delay/strict)
+  (let* ([x 1] [p (delay/strict (set! x (add1 x)) x)])
+    (test (promise? p)
+          x => 2
+          (force p) => 2
+          x => 2
+          (force (delay/strict (values 1 2 3))) => (values 1 2 3)
+          (promise? (force (delay/strict (delay 1)))))))
+
 (define (test-delay/sync)
   (letrec ([p (delay/sync (force p))])
     (test (force p) =error> "reentrant"))
@@ -179,5 +188,9 @@
         do (test-basic-promise-behavior)
         do (test-printout)
         do (test-delay/name)
+        do (test-delay/strict)
         do (test-delay/sync)
-        do (test-delay/thread)))
+        do (test-delay/thread)
+        ;; misc tests
+        (let ([x (lazy (delay 1))]) (force x) (force x)) => 1
+        ))