; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.

; Higher-level proposal stuff.

; Macros based on this are in proposal-syntax.scm.

; Execute THUNK atomically with its own proposal, saving and restoring
; the current proposal.

(define (call-atomically thunk)
  (let ((old (current-proposal)))
    (let loop ()
      (set-current-proposal! (make-proposal))
      (call-with-values thunk
			(lambda results
			  (if (maybe-commit)
			      (begin
				(set-current-proposal! old)
				(apply values results))
			      (loop)))))))

; Ditto, but no values are returned.

(define (call-atomically! thunk)
  (with-new-proposal (lose)
    (thunk)
    (or (maybe-commit)
	(lose)))
  (values))

; Same again, except that we use the current proposal, if there is one
; (and don't commit on the existing proposal).

(define (call-ensuring-atomicity thunk)
  (if (current-proposal)
      (thunk)
      (call-atomically thunk)))

(define (call-ensuring-atomicity! thunk)
  (if (current-proposal)
      (thunk)
      (call-atomically! thunk)))

; Useful for getting rid of a proposal before raising an error.

(define (remove-current-proposal!)
  (set-current-proposal! #f))

; Useful for detecting that a proposal should be got rid of.

(define (proposal-active?)
  (x->boolean (current-proposal)))

; For use when an inconsistency has been detected.  The SET-CAR! ensures that
; the earlier PROVISIONAL-CAR will fail.

(define (invalidate-current-proposal!)
  (let ((value (provisional-car j-random-pair)))
    (set-car! j-random-pair (cons #f #f))
    value))

(define j-random-pair (list #f))
