suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Removed `with-handlers*' that was causing a problem in some long

Browse Source 
nested streams example (from Jos Koot).
* Replaced with `call-with-exception-handler' which is (intentionally)
  not tail-recursive, but it seems to work fine now.
* The `lazy' form is restricted to single-valued expressions only.

svn: r10416
This commit is contained in:
Eli Barzilay 2008-06-23 04:07:12 +00:00
parent 3e0de8592d
commit 945dc376d2
1 changed files with 112 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
collects/scheme/promise.ss
View File

@ -1,78 +1,67 @@
(module promise '#%kernel #lang scheme/base
;; This module implements "lazy promises" and a `force' that is iterated ;; This module implements "lazy promises" and a `force' that is iterated
;; through them. ;; through them.
;; This is similar to the *new* version of srfi-45 -- see the post-finalization
;; discussion at http://srfi.schemers.org/srfi-45/ for more details;
;; specifically, this version is the `lazy2' version from
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a
;; `lazy3' variant of `force' that deals with multiple values is included and
;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme
;; (except that `force' is identity for non promise values), and `force'+`lazy'
;; are sufficient for implementing the lazy language.
(#%require "private/more-scheme.ss" "private/small-scheme.ss" ;; This is similar to the *new* version of srfi-45 -- see the
"private/define.ss" ;; post-finalization discussion at http://srfi.schemers.org/srfi-45/
(rename "private/define-struct.ss" define-struct define-struct*) ;; for more details; specifically, this version is the `lazy2' version
(for-syntax '#%kernel ;; from
"private/stxcase-scheme.ss" "private/small-scheme.ss")) ;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html
;; and (a `lazy3' variant of `force' that deals with multiple values
;; is included and commented). Note: if you use only `force'+`delay'
;; it behaves as in Scheme (except that `force' is identity for non
;; promise values), and `force'+`lazy' are sufficient for implementing
;; the lazy language.
(#%provide lazy delay force promise?) (require (for-syntax scheme/base))
(provide lazy delay force promise?)
(define running (define (promise-printer promise port write?)
(lambda () (error 'force "reentrant promise")))
(define (promise-printer promise port write?)
(let loop ([p (promise-val promise)]) (let loop ([p (promise-val promise)])
(cond (cond [(procedure? p)
[(procedure? p)
(cond [(object-name p) (cond [(object-name p)
=> (lambda (n) (fprintf port "#<promise:~a>" n))] => (lambda (n) (fprintf port "#<promise:~a>" n))]
[else (display "#<promise>" port)])] [else (display "#<promise>" port)])]
;; no values
[(null? p) (fprintf port "#<promise!(values)>")]
[(pair? p)
;; single or multiple values
(fprintf port
(if write? "#<promise!~a~s" "#<promise!~a~a")
(if (null? (cdr p)) "" "(values ")
(car p))
(when (pair? (cdr p))
(let ([fmt (if write? " ~s" " ~a")])
(for-each (lambda (x) (fprintf port fmt x)) (cdr p))))
(unless (null? (cdr p)) (display ")" port))
(display ">" port)]
[(promise? p) (loop (promise-val p))] ; hide sharing [(promise? p) (loop (promise-val p))] ; hide sharing
[else (loop (list p))]))) [(exn? p) (display "#<promise!exception>" port)] ; exn when forced
;; values
[(null? p) (fprintf port "#<promise!(values)>")]
[(null? (cdr p))
(fprintf port (if write? "#<promise!~s>" "#<promise!~a>") (car p))]
[else
(display "#<promise!(values" port)
(let ([fmt (if write? " ~s" " ~a")])
(for ([x p]) (fprintf port fmt x)))
(display ")>" port)])))
(define-struct promise (val) (define-struct promise (val)
#:mutable #:mutable
#:property prop:custom-write promise-printer) #:property prop:custom-write promise-printer)
;; A promise value can hold
;; - <thunk>: usually a delayed promise, but can also hold a `running' thunk
;; - <promise>: a shared (redirected) promise that points at another one
;; - (list <value> ...): forced promise (possibly multiple-values, usually one)
;; - <exn>: a forced promise, where an exception happened when forcing
;; <promise> ::= ;; Creates a `composable' promise
;; | (promise <thunk>) delayed promise, maybe currently running, maybe an exn promise ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
;; | (promise (list <object>)) forced promise (possibly multi-valued) (define-syntax (lazy stx)
;; | (promise <promise>) shared promise
;; | (promise <object>) forced promise, since values
;; Creates a `composable' promise
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
(define-syntax (lazy stx)
(syntax-case stx () (syntax-case stx ()
[(lazy expr) (with-syntax ([proc (syntax-property [(lazy expr) (with-syntax ([proc (syntax-property
(syntax/loc stx (lambda () expr)) (syntax/loc stx (lambda () expr))
'inferred-name (syntax-local-name))]) 'inferred-name (syntax-local-name))])
(syntax/loc stx (make-promise proc)))])) (syntax/loc stx (make-promise proc)))]))
;; Creates a promise that does not compose ;; Creates a promise that does not compose
;; X = (force (delay X)) = (force (lazy (delay X))) ;; X = (force (delay X)) = (force (lazy (delay X)))
;; = (force (lazy^n (delay X))) ;; = (force (lazy^n (delay X)))
;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X))) ;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X)))
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a ;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) ;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
;; (This is not needed with a lazy language (see the above URL for details), ;; (This is not needed with a lazy language (see the above URL for details),
;; but provided for completeness.) ;; but provided for regular delay/force uses.)
(define-syntax (delay stx) (define-syntax (delay stx)
(syntax-case stx () (syntax-case stx ()
[(delay expr) [(delay expr)
(with-syntax ([proc (syntax-property (with-syntax ([proc (syntax-property
@ -81,53 +70,49 @@
(syntax/loc stx (syntax/loc stx
(lazy (make-promise (call-with-values proc list)))))])) (lazy (make-promise (call-with-values proc list)))))]))
;; force iterates on lazy promises (forbid dependency cycles) ;; force iterates on lazy promises (forbids dependency cycles)
;; * (force X) = X for non promises ;; * (force X) = X for non promises
;; * does not deal with multiple values, since they're not used by the lazy ;; * does not deal with multiple values, except for `delay' promises at the
;; language (but see below) ;; leaves
(define handle-results (define (force-proc p root)
(case-lambda [(single) (values #f single)] (let loop1 ([v (p)]) ; does not handle multiple values!
[multi (values #t multi)]))
(define (force-proc p root)
(let loop1 ([p p])
(let-values ([(multi? v) (call-with-values p handle-results)])
(if multi?
(begin ; error here for "library approach" (see above URL)
(set-promise-val! root v)
(apply values v))
(if (promise? v) (if (promise? v)
(let loop2 ([promise* v]) (let loop2 ([promise* v])
(let ([p* (promise-val promise*)]) (let ([p* (promise-val promise*)])
(set-promise-val! promise* root) ; share with root (set-promise-val! promise* root) ; share with root
(cond [(procedure? p*) (loop1 p*)] (cond [(procedure? p*) (loop1 (p*))]
[(promise? p*) (loop2 p*)] [(promise? p*) (loop2 p*)]
[else (set-promise-val! root p*) [else (set-promise-val! root p*)
(cond [(null? p*) (values)] (cond [(exn? p*) (raise p*)]
[(not (pair? p*)) p*] ; is this needed? [(null? p*) (values)]
[(null? (cdr p*)) (car p*)] [(null? (cdr p*)) (car p*)]
[else (apply values p*)])]))) [else (apply values p*)])])))
(begin ; error here for "library approach" (see above URL) (begin ; error here for "library approach" (see above URL)
(set-promise-val! root (list v)) (set-promise-val! root (list v))
v)))))) v))))
(define (force promise) (define (running proc)
(let ([name (object-name proc)])
;; important: be careful not to close over the thunk!
(lambda ()
(if name
(error 'force "reentrant promise ~v" name)
(error 'force "reentrant promise")))))
(define (force promise)
(if (promise? promise) (if (promise? promise)
(let loop ([p (promise-val promise)]) (let loop ([p (promise-val promise)])
(cond (cond [(procedure? p)
[(procedure? p) ;; "mark" root as running (avoids cycles)
;; mark root for cycle detection: (set-promise-val! promise (running p))
(set-promise-val! promise running) (call-with-exception-handler
(with-handlers* ([void (lambda (e) (lambda (exn) (set-promise-val! promise exn) exn)
(set-promise-val! promise (lambda () (force-proc p promise)))]
(lambda () (raise e)))
(raise e))])
(force-proc p promise))]
[(promise? p) (loop (promise-val p))] [(promise? p) (loop (promise-val p))]
[else (cond [(null? p) (values)] [(exn? p) (raise p)]
[(not (pair? p)) p] ; is this needed? [(null? p) (values)]
[(null? (cdr p)) (car p)] [(null? (cdr p)) (car p)]
[else (apply values p)])])) [else (apply values p)]))
;; different from srfi-45: identity for non-promises ;; different from srfi-45: identity for non-promises
promise))) promise))