;;; -*- Mode: Scheme -*-

;;;; Unwind Protection

;;; (UNWIND-PROTECT <thunk> <protector>) applies the nullary procedure
;;; <thunk> in the dynamic context of the call to UNWIND-PROTECT, and
;;; when control can no longer re-enter <thunk>, applies the nullary
;;; procedure <protector> in the dynamic context of the call to
;;; UNWIND-PROTECT.
;;;
;;; This procedure needs better a name.  The author welcomes
;;; suggestions.  See also mit-unwind-protect.scm and
;;; rewind-protect.scm.
;;;
;;; WARNING:  You may not use UNWIND-PROTECT within a rewind-protected
;;; extent, because UNWIND-PROTECT arranges for its protector to be
;;; called within the dynamic context of the call to UNWIND-PROTECT.
;;; If UNWIND-PROTECT were called within a rewind-protected extent,
;;; control may need to re-enter the rewind-protected extent to call
;;; the protector, but rewind-protected extents may not be re-entered.

;;; Assumptions:  After (REGISTER-FINALIZER <object> <procedure>), if
;;; <object>'s storage is reclaimed by the garbage collector, then at
;;; some future time <procedure> will be applied to zero arguments.
;;; (NO-OP <object>) returns an unspecified value but guarantees that
;;; the compiler will not allow <object> to be reclaimed if control
;;; ever reaches that call.

(define (unwind-protect thunk protector)
  (let ((twonkie (cons 0 0)))
    (register-finalizer twonkie (preserving-dynamic-context protector))
    (dynamic-wind
     (lambda () (no-op twonkie))
     thunk
     values)))

(define (preserving-dynamic-context thunk)
  (let ((dynamic-context (current-dynamic-context)))
    (lambda ()
      (with-dynamic-context dynamic-context thunk))))

(define (current-dynamic-context)
  ((call-with-current-continuation
     (lambda (call-with-captured-dynamic-context)
       (lambda ()
         call-with-captured-dynamic-context)))))

(define (with-dynamic-context dynamic-context thunk)
  (call-with-current-continuation
    (lambda (return-to-original-context)
      (dynamic-context
       (lambda ()
         (call-with-values thunk return-to-original-context))))))

;;; Note:  If CWCC sets a bit in each node of the state tree that it
;;; captures, then we can immediately run the protector if control
;;; exits the extent of the thunk and the bit is clear.  For instance,
;;; if there is a nullary predicate CURRENT-STATE-CAPTURED? that
;;; returns true if CWCC has set the bit and false if the bit remains
;;; clear, then we can write:
;;;
;;;   (define (unwind-protect thunk protector)
;;;     (let ((twonkie (cons 0 0))
;;;           (protector (preserving-dynamic-context protector)))
;;;       (register-finalizer twonkie protector)
;;;       (dynamic-wind
;;;        (lambda () (no-op twonkie))
;;;        thunk
;;;        (lambda ()
;;;          (if (not (current-state-captured?))
;;;              (begin
;;;                (deregister-finalizer twonkie protector)
;;;                (protector)))))))
;;;
;;; However, because of how PRESERVING-DYNAMIC-CONTEXT is defined,
;;; this works only for the innermost UNWIND-PROTECT.  Making this
;;; optimization work for arbitrarily nested UNWIND-PROTECTs is left
;;; as an exercise for the reader.