; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME  -*-

; Dynamic winding...

(define (dynamically-bind fetch store! new-val thunk)
  ;; Bug - this isn't synchronized!  We can get screwed by an interrupt.
  (let ((alternate-value (delay (new-val))))
    (let ((swap (lambda ()
		  (let ((temp (delay (fetch))))
		    (force temp)
		    (store! (force alternate-value))
		    (set! alternate-value temp)))))
      (dynamic-wind swap thunk swap))))

(define (unwind-protect thunk out)
  (dynamic-wind (lambda () #f) thunk out))

(define (dynamic-wind in thunk out)
  (perform-one-wind in out)
  (let ((val (thunk)))
    (perform-one-unwind)))

(define *dynamic-state* '())  ;list of (depth in out)

(define (dynamic-depth state)
  (if (null? state) 0 (car (car state))))

(define (perform-one-wind in out)
  (wind-up-to (cons (list (+ (dynamic-depth *dynamic-state*) 1) in out)
		    *dynamic-state*)))

(define (perform-one-unwind)
  (wind-down-to (cdr *dynamic-state*)))

(define (wind-up-to target)
  (cond ((eq? *dynamic-state* target) 'done)
	((null? target)
	 (error "WIND-UP-TO error -- this shouldn't happen!"))
	(else
	 (wind-up-to (cdr target))
	 (without-interrupts
	    (lambda ()
	      ((cadr (car target)))
	      (set! *dynamic-state* target))))))

(define (wind-down-to target)
  (cond ((eq? target *dynamic-state*) 'done)
	((null? *dynamic-state*)
	 (error "WIND-DOWN-TO error -- this shouldn't happen!"))
	(else
	 (without-interrupts
	  (lambda ()
	    (let ((out (caddr (car *dynamic-state*))))
	      (set! *dynamic-state* (cdr *dynamic-state*))
	      (out))))
	 (wind-down-to target))))

(define (change-dynamic-state target)
  (unwind-down-to (common-ancestor-state *dynamic-state* target))
  (wind-up-to target))

(define (common-ancestor-state state1 state2)
  (let ((depth1 (dynamic-depth state1))
	(depth2 (dynamic-depth state2)))
    (let ((state1 (if (> depth1 depth2)
		      (list-tail state1 (- depth1 depth2))
		      state1))
	  (state2 (if (> depth2 depth1)
		      (list-tail state2 (- depth2 depth1))
		      state2)))
      (do ((state1 state1 (cdr state1))
	   (state2 state2 (cdr state2)))
	  ((eq? state1 state2) state1)))))

(define (reset-dynamic-state!)
  (cond ((null? *dynamic-state*) #t)
	(else (perform-one-unwind) (reset-dynamic-state!))))