added promise-forced? and promise-running?

svn: r13160

collects/scheme/promise.ss

@@ -2,7 +2,7 @@
 (#%require "private/small-scheme.ss" "private/more-scheme.ss" "private/define.ss"
            (rename "private/define-struct.ss" define-struct define-struct*)
            (for-syntax '#%kernel "private/stxcase-scheme.ss"))
-(#%provide lazy delay force promise?)
+(#%provide lazy delay force promise? promise-forced? promise-running?)
 
 ;; This module implements "lazy" (composable) promises and a `force'
 ;; that is iterated through them.
@@ -23,6 +23,11 @@
                (fprintf port "#<promise!exn!~a>" (exn-message v))
                (fprintf port (if write? "#<promise!~a>" "#<promise!~s>")
                         `(raise ,v))))]
+          [(running? p)
+           (let ([n (running-name p)])
+             (if n
+               (fprintf port "#<promise:!running!~a>" n)
+               (fprintf port "#<promise:!running>")))]
           [(procedure? p)
            (cond [(object-name p)
                   => (lambda (n) (fprintf port "#<promise:~a>" n))]
@@ -58,12 +63,21 @@
                                       'inferred-name (syntax-local-name))])
                    (syntax/loc stx (make-promise proc)))]))
 
-;; use this to create a value to be raised, make it a procedure so no other
-;; code need to change (we could just use the exceptions -- but any value can
-;; be raised); also make it have a proper printer so we can show such promises
-;; properly.
+;; For simplicity and efficiency this code uses thunks in promise values for
+;; exceptions: this way, we don't need to tag exception values in some special
+;; way and test for them -- we just use a thunk that will raise the exception.
+;; But it's still useful to refer to the exception value, so use an applicable
+;; struct for them.  The same goes for a promise that is being forced: we use a
+;; thunk that will throw a "reentrant promise" error -- and use an applicable
+;; struct so it is identifiable.
 (define-struct reraise (val)
   #:property prop:procedure (lambda (this) (raise (reraise-val this))))
+(define-struct running (name)
+  #:property prop:procedure (lambda (this)
+                              (let ([name (running-name this)])
+                                (if name
+                                  (error 'force "reentrant promise ~v" name)
+                                  (error 'force "reentrant promise")))))
 
 ;; Creates a promise that does not compose
 ;;   X = (force (delay X)) = (force (lazy (delay X)))
@@ -100,21 +114,17 @@
         (set-promise-val! root (list v))
         v))))
 
-;; this is used during computation to avoid reentrant loops (which makes it
-;; non-r5rs, but there's no good uses for allowing that)
-(define (running proc)
-  ;; important: be careful not to close over the thunk!
-  (let ([name (object-name proc)])
-    (if name
-      (lambda () (error 'force "reentrant promise ~v" name))
-      (lambda () (error 'force "reentrant promise")))))
-
 (define (force promise)
   (if (promise? promise)
     (let loop ([p (promise-val promise)])
       (cond [(procedure? p)
-             ;; "mark" root as running (avoids cycles)
-             (set-promise-val! promise (running p))
+             ;; mark the root as running: avoids cycles, and no need to keep
+             ;; banging the root promise value; it makes this non-r5rs, but
+             ;; only practical uses of these things could be ones that use
+             ;; state.
+             ;; (careful: avoid holding a reference to the thunk, to allow
+             ;; safe-for-space loops)
+             (set-promise-val! promise (make-running (object-name p)))
              (call-with-exception-handler
                (lambda (e) (set-promise-val! promise (make-reraise e)) e)
                (lambda () (force-proc p promise)))]
@@ -125,4 +135,15 @@
     ;; different from srfi-45: identity for non-promises
     promise))
 
+(define (promise-forced? promise)
+  (if (promise? promise)
+    (let ([p (promise-val promise)])
+      (or (not (procedure? p)) (reraise? p))) ; #f when running
+    (raise-type-error 'promise-forced? "promise" promise)))
+
+(define (promise-running? promise)
+  (if (promise? promise)
+    (running? (promise-val promise))
+    (raise-type-error 'promise-running? "promise" promise)))
+
 )

collects/scribblings/reference/promise.scrbl

@@ -22,6 +22,7 @@ otherwise.}
 Creates a promise that, when @scheme[force]d, evaluates @scheme[expr]
 to produce its value.}
 
+
 @defform[(lazy expr)]{
 
 Like @scheme[delay], except that if @scheme[expr] produces a promise,
@@ -31,6 +32,7 @@ mostly useful for implementing lazy libraries and languages.  Also
 note that the @scheme[expr] in this case is restricted to one that
 produces a single value.}
 
+
 @defproc[(force [v any/c]) any]{
 
 If @scheme[v] is a promise, then the promise is forced to obtain a
@@ -44,3 +46,14 @@ If @scheme[v] is @scheme[force]d again before the original call to
 @scheme[force] returns, then the @exnraise[exn:fail].
 
 If @scheme[v] is not a promise, then it is returned as the result.}
+
+
+@defproc[(promise-forced? [promise promise?]) boolean?]{
+
+Returns @scheme[#t] if @scheme[promise] has been forced.}
+
+
+@defproc[(promise-running? [promise promise?]) boolean?]{
+
+Returns @scheme[#t] if @scheme[promise] is currently being forced.
+(Note that a promise can be either running or forced but not both.)}

collects/tests/mzscheme/promise.ss

@@ -72,17 +72,23 @@
 
 ;; more tests
 (let ()
-  (define (force+catch x)
-    (with-handlers ([void (lambda (x) (cons 'catch x))]) (force x)))
+  (define (force+catch p)
+    (with-handlers ([void (lambda (x) (cons 'catch x))]) (force p)))
+  (define (forced+running? p) (list (promise-forced? p) (promise-running? p)))
   ;; results are cached
-  (let ([x (delay (random 10000))])
-    (test #t equal? (force x) (force x)))
+  (let ([p (delay (random 10000))])
+    (test #t equal? (force p) (force p)))
   ;; errors are cached
-  (let ([x (delay (error 'foo "blah"))])
-    (test #t equal? (force+catch x) (force+catch x)))
+  (let ([p (delay (error 'foo "blah"))])
+    (test #t equal? (force+catch p) (force+catch p)))
   ;; other raised values are cached
-  (let ([x (delay (raise (random 10000)))])
-    (test #t equal? (force+catch x) (force+catch x)))
+  (let ([p (delay (raise (random 10000)))])
+    (test #t equal? (force+catch p) (force+catch p)))
+  ;; test the predicates
+  (letrec ([p (delay (forced+running? p))])
+    (test '(#f #f) forced+running? p)
+    (test '(#f #t) force p)
+    (test '(#t #f) forced+running? p))
   )
 
 (report-errs)