101 lines
3.2 KiB
Scheme
101 lines
3.2 KiB
Scheme
|
; -*- 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.")
|
||
|
|
|
||
|
|
;;;; Dynamic-wind
|
||
|
|
|
||
|
|
|
||
|
|
; This is a version of dynamic-wind 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.
|
||
|
|
|
||
|
|
|
||
|
|
; Dynamic-wind
|
||
|
|
|
||
|
|
(define (dynamic-wind in body out)
|
||
|
|
(in)
|
||
|
|
(let ((results (let-dynamic-point (let ((here (get-dynamic-point)))
|
||
|
|
(make-point (+ (point-depth here) 1)
|
||
|
|
in
|
||
|
|
out
|
||
|
|
(get-dynamic-env)
|
||
|
|
here))
|
||
|
|
(lambda ()
|
||
|
|
(call-with-values body list)))))
|
||
|
|
(out)
|
||
|
|
(apply values results)))
|
||
|
|
|
||
|
|
; call-with-current-continuation
|
||
|
|
|
||
|
|
(define (call-with-current-continuation proc)
|
||
|
|
(primitive-cwcc
|
||
|
|
(lambda (cont)
|
||
|
|
(let ((env (get-dynamic-env)))
|
||
|
|
(proc (continuation->procedure cont env)))))) ;don't close over proc
|
||
|
|
|
||
|
|
(define (continuation->procedure cont env)
|
||
|
|
(lambda results
|
||
|
|
(travel-to-point! (get-dynamic-point) (env-dynamic-point env))
|
||
|
|
(set-dynamic-env! env)
|
||
|
|
(with-continuation cont
|
||
|
|
(lambda () (apply values results)))))
|
||
|
|
|
||
|
|
; Point in state space = <depth, in, out, dynamic-env, parent>
|
||
|
|
; dynamic-env = dynamic environment for execution of the in and out thunks
|
||
|
|
|
||
|
|
(define-record-type point :point
|
||
|
|
(make-point depth in out dynamic-env parent)
|
||
|
|
(depth point-depth)
|
||
|
|
(in point-in)
|
||
|
|
(out point-out)
|
||
|
|
(dynamic-env point-dynamic-env)
|
||
|
|
(parent point-parent))
|
||
|
|
|
||
|
|
(define root-point ;Shared among all state spaces
|
||
|
|
(make-point 0
|
||
|
|
(lambda () (error "winding in to root!"))
|
||
|
|
(lambda () (error "winding out of root!"))
|
||
|
|
'() ;(empty-dynamic-env) ;Should never be seen
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(define $dynamic-point (make-fluid root-point))
|
||
|
|
(define (get-dynamic-point) (fluid $dynamic-point))
|
||
|
|
(define (env-dynamic-point env)
|
||
|
|
(fluid-lookup env $dynamic-point))
|
||
|
|
(define (let-dynamic-point point thunk)
|
||
|
|
(let-fluid $dynamic-point point thunk))
|
||
|
|
|
||
|
|
; Go to a point in state space. This involves running out-thunks from
|
||
|
|
; the current point out to its common ancestor with the target, and
|
||
|
|
; then running in-thunks from the ancestor to the target.
|
||
|
|
|
||
|
|
(define (travel-to-point! here target)
|
||
|
|
(cond ((eq? here target) 'done)
|
||
|
|
((< (point-depth here)
|
||
|
|
(point-depth target))
|
||
|
|
(travel-to-point! here (point-parent target))
|
||
|
|
(set-dynamic-env! (point-dynamic-env target))
|
||
|
|
((point-in target)))
|
||
|
|
(else
|
||
|
|
(set-dynamic-env! (point-dynamic-env here))
|
||
|
|
((point-out here))
|
||
|
|
(travel-to-point! (point-parent here) target))))
|
||
|
|
|
||
|
|
|
||
|
|
; (put 'let-dynamic-point 'scheme-indent-hook 1)
|