diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index d604f2e4e7..084dbb1cd0 100644 --- a/collects/scheme/promise.ss +++ b/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 "#" (exn-message v)) (fprintf port (if write? "#" "#") `(raise ,v))))] + [(running? p) + (let ([n (running-name p)]) + (if n + (fprintf port "#" n) + (fprintf port "#")))] [(procedure? p) (cond [(object-name p) => (lambda (n) (fprintf port "#" 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))) + ) diff --git a/collects/scribblings/reference/promise.scrbl b/collects/scribblings/reference/promise.scrbl index d8c2af3254..de52cd3d70 100644 --- a/collects/scribblings/reference/promise.scrbl +++ b/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.)} diff --git a/collects/tests/mzscheme/promise.ss b/collects/tests/mzscheme/promise.ss index 51e011e383..8ff0f3ed14 100644 --- a/collects/tests/mzscheme/promise.ss +++ b/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)