1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100

; * Mode: Scheme; Syntax: Scheme; Package: Scheme; *
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; This is file wind.scm. (Rhymes with "find," not "pinned.")
;;;; Dynamicwind
; This is a version of dynamicwind that tries to do "the right thing"
; in the presence of multiple threads of control.
; This definition of "the right thing" is due to Pavel Curtis, and is
; the one used in Scheme Xerox. It is very different from what you will
; find in, say, MIT Scheme.
;
; When we want to go to a new target state (e.g. on invoking a
; continuation), we ascend to the nearest common ancestor of the
; current state and the target state, executing the "out" (or
; "unwind") thunk for each state on the way; then we climb back down
; to the target state executing the "in" thunk for each state. Unlike
; the Hanson/Lamping algorithm, the tree of states is not altered in
; any way.
;
; Each thread starts out in the root state, but continuations capture
; the state where they're created.
; Dynamicwind
(define (dynamicwind in body out)
(in)
(let ((results (letdynamicpoint (let ((here (getdynamicpoint)))
(makepoint (+ (pointdepth here) 1)
in
out
(getdynamicenv)
here))
(lambda ()
(callwithvalues body list)))))
(out)
(apply values results)))
; callwithcurrentcontinuation
(define (callwithcurrentcontinuation proc)
(primitivecwcc
(lambda (cont)
(let ((env (getdynamicenv)))
(proc (continuation>procedure cont env)))))) ;don't close over proc
(define (continuation>procedure cont env)
(lambda results
(traveltopoint! (getdynamicpoint) (envdynamicpoint env))
(setdynamicenv! env)
(withcontinuation cont
(lambda () (apply values results)))))
; Point in state space = <depth, in, out, dynamicenv, parent>
; dynamicenv = dynamic environment for execution of the in and out thunks
(definerecordtype point :point
(makepoint depth in out dynamicenv parent)
(depth pointdepth)
(in pointin)
(out pointout)
(dynamicenv pointdynamicenv)
(parent pointparent))
(define rootpoint ;Shared among all state spaces
(makepoint 0
(lambda () (error "winding in to root!"))
(lambda () (error "winding out of root!"))
'() ;(emptydynamicenv) ;Should never be seen
#f))
(define $dynamicpoint (makefluid rootpoint))
(define (getdynamicpoint) (fluid $dynamicpoint))
(define (envdynamicpoint env)
(fluidlookup env $dynamicpoint))
(define (letdynamicpoint point thunk)
(letfluid $dynamicpoint point thunk))
; Go to a point in state space. This involves running outthunks from
; the current point out to its common ancestor with the target, and
; then running inthunks from the ancestor to the target.
(define (traveltopoint! here target)
(cond ((eq? here target) 'done)
((< (pointdepth here)
(pointdepth target))
(traveltopoint! here (pointparent target))
(setdynamicenv! (pointdynamicenv target))
((pointin target)))
(else
(setdynamicenv! (pointdynamicenv here))
((pointout here))
(traveltopoint! (pointparent here) target))))
; (put 'letdynamicpoint 'schemeindenthook 1)
