1  unwind-protect that recognizes escaping continuations

In Pitman's first proposal, the new call/cc (let's call it call/cc-new) takes two arguments. The second argument is a procedure that is applied to the current continuation. Whether this continuation is an escaping or a full continuation depends on whether the first argument is true or false. Thus (call/cc-new #t ...) produces escaping continuations, and (call/cc-new #f ...) produces full continuations.⁵

unwind-protect interacts with call/cc-new as follows. If the unwind-protect body invokes an escaping continuation provided by an enclosing call/cc-new #t, then the postlude is performed. To accomplish this, the cob generated by call/cc-new #t keeps a list (my-postludes) of all the unwind-protect postludes within its dynamic extent. Since, a call to call/cc-new #t cannot know of the unwind-protects that will be called in its dynamic extent, it is the job of each unwind-protect to update the my-postludes of its enclosing call/cc-new #ts. It is enough that we have a fluid variable *current-escape-prompt*. Each call/cc-new #t sets *current-escape-prompt* to the cob it generates, and remembers the previous *current-escape-prompt* as prev-escape-prompt. When an unwind-protect seeks to update the my-postludes list of its nearest *current-escape-prompt*, the updates are propagated via prev-escape-prompt, so all the concentrically enclosing *current-escape-prompt*s become aware of the unwind-protect.

The unwind-protect doctors the postlude that it so propagates. Any time a postlude is executed, it has to be deleted from the my-postludes list of the enclosing *current-escape-prompt*s.

Updating and deleting the my-postludes of a cob is accomplished by making the cob respond to update and delete messages. These messages are unforgeable objects provided by lexical scoping, and thus cannot be generated by external code. To such external code, the cob looks like a regular continuation, and any value it is given will be thrown to the context captured by the continuation (unless we deem it an error by the semantics of unwind-protect.)

There is one other constraint that must be programmed in. Any full continuation captured within the unwind-protect body can be invoked only if the unwind-protect hasn't already been exited, either via normal exit or by an escaping continuation. To implement this, we define a variable *current-unwind-protect-alive?* that is fluidly set by each unwind-protect. *current-unwind-protect-alive?* is a thunk that returns the aliveness of its unwind-protect. An unwind-protect's postlude will remember to turn off the aliveness, so its *current-unwind-protect-alive?* will return false.

A call/cc-new #f creates a full-continuation cob that remembers its nearest unwind-protect's *current-unwind-protect-alive?*, using the variable my-unwind-protect-alive?. Calling the cob implies entering this unwind-protect. By checking my-unwind-protect-alive?, the cob prevents its continuation from being invoked if the unwind-protect has already been exited.

The following is the entire code for the modified call/cc, and unwind-protect. Note that Will Clinger has written a more concise implementation [1] that effectively uses dynamic-wind and thereby avoids much of the variable bookkeeping in my code.

;uwesc.scm
;An unwind-protect in portable Scheme
;  (assumes fluid-let defined in terms of dynamic-wind)
;Dorai Sitaram
;May 11, 2003

;Don't load this file twice, as it
;redefines call/cc.

(define delq!
  (lambda (x s)
    ;destructively removes x from list s,
    ;returns modified s.
    (let loop ((s s))
      (cond ((null? s) s)
            ((eq? (car s) x) (loop (cdr s)))
            (else (set-cdr! s (loop (cdr s)))
                  s)))))

(define call/cc-new #f)
(define unwind-protect-proc #f)

(let ((call/cc-orig call/cc)
      (update (list 'update))
      (delete (list 'delete))
      (*current-escape-prompt* (lambda (v) (lambda (v2) #f))) 
      (*current-unwind-protect-alive?* (lambda () #t)))

  (set! call/cc-new
    (lambda (once? proc)
      (if once?
          (call/cc-orig
            (lambda (k)
              (let ((prev-escape-prompt *current-escape-prompt*)
                    (my-postludes '())
                    (already-called? #f))
                (fluid-let ((*current-escape-prompt*
                              (lambda (v)
                                (cond ((eq? v update)
                                       (lambda (pl)
                                         (set! my-postludes
                                           (cons pl my-postludes))
                                         ((prev-escape-prompt update) pl)))
                                      ((eq? v delete)
                                       (lambda (pl)
                                         (set! my-postludes
                                           (delq! pl my-postludes))
                                         ((prev-escape-prompt delete) pl)))
                                      (already-called?
                                        (error 'calling-escaping-cont-twice))
                                      (else
                                        (set! already-called? #t)
                                        (for-each 
                                          (lambda (pl) (pl))
                                          my-postludes)
                                        (k v))))))
                  (*current-escape-prompt*
                    (proc *current-escape-prompt*))))))
          (call/cc-orig
            (lambda (k)
              (let ((my-unwind-protect-alive? *current-unwind-protect-alive?*))
                (proc
                  (lambda (v)
                    (if (my-unwind-protect-alive?)
                        (k v)
                        (error 
                          'trying-to-enter-exited-unwind-protect))))))))))

  (set! unwind-protect-proc
    (lambda (body postlude)
      (let ((my-escape-prompt *current-escape-prompt*)
            (alive? #t))
        (fluid-let ((*current-unwind-protect-alive?* (lambda () alive?)))
          (letrec ((pl (lambda ()
                         (set! alive? #f)
                         (postlude)
                         ((my-escape-prompt delete) pl))))
            ((my-escape-prompt update) pl)
            (let ((res (body)))
              (pl)
              res))))))

  )

(define-syntax unwind-protect
  (syntax-rules ()
    ((unwind-protect body postlude)
     (unwind-protect-proc 
       (lambda () body) (lambda () postlude)))))

;OR
;
;(define-macro unwind-protect
;  (lambda (body postlude)
;    `(unwind-protect-proc
;       (lambda () ,body) (lambda () ,postlude))))

(set! call/cc call/cc-new)