2  unwind-protect that recognizes last-use continuations

Pitman proposes another version of call/cc (called call/cc-new in the code below), one whose continuations take a second argument specifying whether the current use is the last use. The corresponding unwind-protect performs postludes on an exiting continuation only if it is last-use.⁶ Once again, an unwind-protect, once exited by whatever means, should not allow a continuation to jump into it. (I have added an additional constraint that a continuation whose capture and invocation is localized within an unwind-protect should not perform that unwind-protect's postlude, even if the continuation invocation is last-use.)

This variant pair of call/cc and unwind-protect can be obtained by appropriately modifying the cob. Here is the complete code:

;uwlast.scm
;An unwind-protect in portable Scheme
;  (assumes fluid-let defined in terms of dynamic-wind)
;Dorai Sitaram
;May 13, 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-callcc-prompt* (lambda (m v) #f)) 
      (*current-unwind-protect-local-continuations* '())
      (*current-unwind-protect-alive?* (lambda () #t)))

  (set! call/cc-new
    (lambda (proc)
      (call/cc-orig
        (lambda (k)
          (set! *current-unwind-protect-local-continuations*
            (cons k *current-unwind-protect-local-continuations*))
          (let ((prev-callcc-prompt *current-callcc-prompt*)
                (my-unwind-protect-alive? *current-unwind-protect-alive?*)
                (my-postludes '())
                (no-more-uses? #f))
            (fluid-let ((*current-callcc-prompt*
                          (lambda (msg v)
                            (cond ((eq? msg update)
                                   (set! my-postludes
                                     (cons v my-postludes))
                                   (prev-callcc-prompt update v))
                                  ((eq? msg delete)
                                   (set! my-postludes
                                     (delq! v my-postludes))
                                   (prev-callcc-prompt delete v))
                                  (no-more-uses?
                                    (error 'calling-used-up-cont))
                                  ((not (my-unwind-protect-alive?))
                                   (error 'trying-to-enter-exited-unwind-protect))
                                  (msg (set! no-more-uses? #t)
                                       (if (not (memq k *current-unwind-protect-local-continuations*))
                                           (for-each (lambda (pl) (pl))
                                                     my-postludes))
                                       (k v))
                                  (else (k v))))))
              (*current-callcc-prompt* 
                #f (proc *current-callcc-prompt*))))))))

  (set! unwind-protect-proc
    (lambda (body postlude)
      (let ((my-callcc-prompt *current-callcc-prompt*)
            (alive? #t))
        (fluid-let ((*current-unwind-protect-alive?* (lambda () alive?))
                    (*current-unwind-protect-local-continuations* '()))
          (letrec ((pl (lambda ()
                         (set! alive? #f)
                         (postlude)
                         (my-callcc-prompt delete pl))))
            (my-callcc-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)