<<>>
<<;;; DynamicWind.scheme>>
<<;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on June 2, 1988 3:12:29 pm PDT>>
<<;;; Michael Plass, January 20, 1989 3:54:00 pm PST>>

<<(herald>>
<<(env (make-environment "Dynamic Wind" implementation user))>>
<<(export cedar-scheme>>
<<dynamic-wind)>>
<<(export scheme-essentials>>
<<call/cc (call-with-current-continuation call/cc)))>>

(export (dynamic-wind call/cc)
(define state '())

(define (dynamic-wind prelude body postlude)
(set! state (cons (cons prelude postlude) state))
(prelude)
(let ((value (body)))
(postlude)
(set! state (cdr state))
value))

(define (prelude entry)
(car entry))

(define (postlude entry)
(cdr entry))

(define (call/cc f)
"Apply F to the current continuation"
(primitive-call/cc
(lambda (k)
(let ((my-state state))
(f
(lambda (v)
"A Continuation"
(define (catch-up-old count old new)
(cond
((zero? count)
(lock-step old new '()))
(else
((postlude (car old)))
(catch-up-old (- count 1) (cdr old) new))))

(define (catch-up-new count old new-ahead new-behind)
(cond
((zero? count)
(lock-step old new-ahead new-behind))
(else
(let ((save (cdr new-ahead)))
(set-cdr! new-ahead new-behind)
(catch-up-new (- count 1) old save new-ahead)))))

(define (lock-step old new-ahead new-behind)
(cond
((eq? old new-ahead)
(do-entries new-behind new-ahead))
(else
((postlude (car old)))
(let ((save (cdr new-ahead)))
(set-cdr! new-ahead new-behind)
(lock-step (cdr old) save new-ahead)))))

(define (do-entries ahead behind)
(cond
((null? ahead)
(set! state behind)
(k v))
(else
((prelude (car ahead)))
(let ((save (cdr ahead)))
(set-cdr! ahead behind)
(do-entries save ahead)))))

(let ((old-length (length state))
   (new-length (length my-state)))
(cond
((< new-length old-length)
(catch-up-old (- old-length new-length) state my-state))
((= new-length old-length)
(lock-step state my-state '()))
(else
(catch-up-new (- new-length old-length)
state my-state '()))))))))))
)

(define call-with-current-continuation call/cc)