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

;;;; Unwind Protection for MIT Scheme

;;; (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 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.
;;;
;;; Subtle detail:  Unlike REWIND-PROTECT, UNWIND-PROTECT does not
;;; guarantee that interrupts are disabled during <protector>.
;;; REWIND-PROTECT, being implemented in terms of DYNAMIC-WIND,
;;; guarantees that (non-GC) interrupts are disabled during
;;; <protector>.

(declare (usual-integrations))

(define continuation-finalizer
  (make-gc-finalizer (lambda (protector) (if protector (protector)))
                     cell?
                     cell-contents
                     set-cell-contents!))

(define (make-protector-cell protector)
  (let ((protector-cell
         (make-cell (preserving-dynamic-context protector))))
    (add-to-gc-finalizer! continuation-finalizer protector-cell)
    protector-cell))

(define preserving-dynamic-context
  (let ((get-dynamic-state
         (access GET-DYNAMIC-STATE
                 (->environment '(RUNTIME STATE-SPACE))))
        (set-dynamic-state!
         (access SET-DYNAMIC-STATE!
                 (->environment '(RUNTIME STATE-SPACE)))))
    (lambda (protector)
      (let ((protector-state (get-dynamic-state)))
        (lambda ()
          (let ((state (get-dynamic-state)))
            (set-dynamic-state! protector-state #f)
            (protector)
            (set-dynamic-state! state #f)))))))

(define (unwind-protect thunk protector)
  (let ((protector-cell (make-protector-cell protector)))
    (dynamic-wind
     (lambda () (identity-procedure protector-cell))
     thunk
     (lambda () unspecific))))