; Test 




(lisp:defun primitive-catch (proc)
  (lisp:funcall proc #'(lisp:lambda (val)
			 (lisp:return-from primitive-catch val))))

(lisp:defun primitive-throw (fun val)
  (lisp:funcall fun val))

(define (without-interrupts thunk)
  (let* ((temp (set-enabled-interrupts! 0))
	 (val (thunk)))
    (set-enabled-interrupts! temp)
    val))

; Dynamic binding

(define *fluid-env* '())

(define (make-fluid top-level-value)
  (make-cell top-level-value '<fluid>))

(define (fluid cell)
  (let ((probe (assq cell *fluid-env*)))
    (if probe (cdr probe) (contents cell))))

(define (set-fluid! cell val)
  (let ((probe (assq cell *fluid-env*)))
    (if probe (set-cdr! probe val) (set-contents! cell val))))

(define (let-fluid cell val thunk)
  (call-with-current-continuation
      (lambda (cont)
	(set! *fluid-env* (cons (cons cell val) *fluid-env*))
	(cont (thunk)))))

(define (call-with-current-continuation proc)
  (primitive-catch
     (lambda (cont)
       (let ((env *fluid-env*))
	 (proc (lambda (val)
		 (set! *fluid-env* env)
		 (primitive-throw cont val)))))))

; Unwind protection
;  This might be better if recast using Hanson/Lamping state spaces
;  (i.e. dynamic-wind).

(define unwind-protections (make-fluid '()))

(define (unwind-protect thunk protection)
  ;; Let S1 = the dynamic state at this point...
  (let ((k (call-with-current-continuation
	     (lambda (cont)
	       (let-fluid unwind-protections
			  (cons cont (fluid unwind-protections))
			  (lambda ()
			    (lisp:format t "~&Doing body: ~S" (length (fluid unwind-protections)))
			    ;; Let S2 = the dynamic state at this point...
			    (let ((val (thunk)))
			      (lambda () val))))))))
    (lisp:format t "~&Doing exit form: ~S" (length (fluid unwind-protections)))
    ;; and this executes in S1.
    (protection)
    (k)))

(define (call-with-protected-continuation proc)
  (let ((p (fluid unwind-protections)))
    (call-with-current-continuation
	(lambda (cont)
	  (proc (lambda (val)
		  (let ((q (fluid unwind-protections)))
		    ;; We must perform all protect actions from
		    ;; q out to p.
		    (if (list-tail? p q)
			(let loop ((q q))
			  (lisp:format t "~&At unwind loop: ~S" (length (fluid unwind-protections)))
			  (if (eq? q p)
			      ;; We have arrived.
			      (cont val)
			      ;; Not there yet; pop out another level.
			      ((car q) (lambda ()
					 ;; Assuming that (fluid unwind-protections)
					 ;; and (cdr q) have the same value here...
					 ;; probably not valid, but who knows?
					 (loop (fluid unwind-protections))))))
			(error "you can only throw up")))))))))

(define (list-tail? l1 l2)
  (or (eq? l1 l2)
      (and (not (null? l2))
	   (list-tail? l1 (cdr l2)))))

(define (tst)
  (set! x 'lose)
  (let ((val
         (call-with-protected-continuation
	   (lambda (k)
	     (newline) (write 'before-body)
	     (unwind-protect (lambda ()
			       (newline) (write 'in-body)
			       (k 'ok))
			     (lambda () 
			       (newline) (write 'in-unwind)
			       (set! x 'win)))))))
    (newline)
    (write val)
    (newline)
    (write x)))