by uriel.
The code in this page presents a Guile module that implements compensation stacks: syntactic sugar that allows us to write code that allocates a resource near the code that releases it in case of error.
Compensation stacks are described in ''Finding and Preventing Run-Time Error Handling Mistakes'', Weimer and Necula (1), (URL last verified on Wed May 2, 2007).
(1) http://www.cs.virginia.edu/~weimer/papers/WN-FindingAndPreventing.pdf
In this document's jargon: a compensation is a chunk of code that undoes a resource allocation performed in another chunk, example:
(define port (open-file "/tmp/proof.1" "w+"))
must be compensated by:
(close-port port)
Compensation forms are embedded in a closure and pushed on a stack, so that, in case of error, it is possible to evaluate them in allocation-reversed order.
A form that makes use of a compensations stack looks like this:
(with-compensations
(compensate
ALLOC-FORMS-1
(with COMP-FORMS-1))
(compensate
ALLOC-FORMS-2
(with COMP-FORMS-2))
BODY-FORMS)
both with-compensations and compensate are macros; to gain a little execution speed we accept code duplication in their expansion.
with-compensation does not invokes the compensations before returning, but it is possible to do it by explicitly invoking the compensations function.
Another useful form is:
(let-compensations* ((a (compensate
ALLOC-FORMS-1
(with COMP-FORMS-1)))
(b (compensate
ALLOC-FORMS-2
(with COMP-FORMS-2))))
BODY-FORMS)
in which the return value of the ALLOC-FORMS is stored in local bindings; if no error occurs: before returning let-compensations* invokes all the compensation closures in reversed order.
with-compensations makes use of a fluid to instantiate a new compensations stack and embeds all its arguments in the body of a catch form; the following:
(with-compensations FORMS)
expands to:
(with-fluid *compensations* '()
(catch #t
(lambda () FORMS)
(lambda (key . args)
(for-each (lambda (closure) (false-if-exception (closure)))
(fluid-ref *compensations*))
(apply throw key args))))
we see that:
A compensate form like:
(compensate
ALLOC-FORMS
(with COMP-FORMS))
is expanded to:
(let ((<symbol> (begin ALLOC-FORMS)))
(fluid-set! *compensations*
(cons (lambda () COMP-FORMS)
(fluid-ref *compensations*)))
<symbol>)
that is:
A form like:
(let-compensations* ((a (compensate
ALLOC-FORMS-1
(with COMP-FORMS-1)))
(b (compensate
ALLOC-FORMS-2
(with COMP-FORMS-2))))
BODY-FORMS)
is expanded to:
(with-compensations
(let* ((a #f)
(b #f))
(set! a (compensate
ALLOC-FORMS-1
(with COMP-FORMS-1)))
(set! b (compensate
ALLOC-FORMS-2
(with COMP-FORMS-2)))
(let ((<symbol> (begin BODY-FORMS)))
(compensations)
<symbol>)))
that is:
(define-module (compensations) #:export (*compensations* with-compensations let-compensations* compensate compensations)) (define *compensations* (make-fluid)) (define (compensations) (for-each (lambda (closure) (false-if-exception (closure))) (fluid-ref *compensations*))) (define-macro (with-compensations . FORMS) `(with-fluid* *compensations* '() (lambda () (catch #t (lambda () ,@FORMS) (lambda (key . args) (for-each (lambda (closure) (false-if-exception (closure))) (fluid-ref *compensations*)) (apply throw key args)))))) (define-macro (let-compensations* bindings . FORMS) (if (null? bindings) `(let () ,@FORMS) (let ((BINDINGS '()) (COMPS '()) (RESULT (make-symbol "let-result"))) (for-each (lambda (ell) (set! BINDINGS (append BINDINGS (list (list (car ell) #f)))) (set! COMPS (append COMPS (list (list 'set! (car ell) (cadr ell)))))) bindings) `(with-compensations (let* ,BINDINGS ,@COMPS (let ((,RESULT (begin ,@FORMS))) (compensations) ,RESULT)))))) (define-macro (compensate . args) (let* ((rargs (reverse args)) (with-form (car rargs)) (ALLOC-FORMS (reverse (cdr rargs))) (RESULT (make-symbol "compensate-result"))) (if (not (eq? 'with (car with-form))) (scm-error 'wrong-type-arg 'compensate "expected 'with' form got: ~A" (list with-form) #f)) `(let ((,RESULT (begin ,@ALLOC-FORMS))) (fluid-set! *compensations* (cons (lambda () ,@(cdr with-form)) (fluid-ref *compensations*))) ,RESULT)))
If we save the current directory both the module file, compensations.scm, and the test file compensations-tests.scm: the tests can be executed with the shell command:
$ GUILE_LOAD_PATH=${PWD} guile -s compensations-tests.scm
;;; compensations-test.scm -- (use-modules (compensations)) ;; ------------------------------------------------------------ (define-macro (test DESCR FORM) `(begin (format #t "~%* ~A:~%~%" ,DESCR) (catch #t (lambda () ,FORM) (lambda (key . args) (format (current-error-port) "catched error key: ~A~%" key))))) ;; ------------------------------------------------------------ (test "No error" (with-compensations (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%"))) (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))) (format #t "Ciao!~%") (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "Ciao!~%") (format #t "Ciao!~%"))) ;; ------------------------------------------------------------ (test "No error, explicit compensations invocation" (with-compensations (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%"))) (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))) (format #t "Ciao!~%") (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "Ciao!~%") (format #t "running compensations...~%") (compensations))) ;; ------------------------------------------------------------ (test "Error in the body" (with-compensations (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%"))) (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))) (format #t "throwing from body...~%") (throw 'misc-error))) ;; ------------------------------------------------------------ (test "Error in resource allocation" (with-compensations (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%"))) (compensate (format #t "throwing from allocation 2...~%") (throw 'misc-error) (with (format #t "compensation 2~%"))) (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "Ciao!~%"))) ;; ------------------------------------------------------------ (test "Throwing from the body and error in compensation form" (with-compensations (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%"))) (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "throwing from compensation 2...~%") (throw 'nested-error))) (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "throwing from body...~%") (throw 'misc-error))) ;; ------------------------------------------------------------ (test "Let, no error" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%")))) (b (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))))) (format #t "Ciao!~%") (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "Ciao!~%") (format #t "Ciao!~%"))) ;; ------------------------------------------------------------ (test "Let, no error" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%")))) (b (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))))) (format #t "Ciao!~%") (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))) (format #t "Ciao!~%") (format #t "running compensations...~%"))) ;; ------------------------------------------------------------ (test "Error in the body" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%")))) (b (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensation 2~%"))))) (format #t "throwing from body...~%") (throw 'misc-error))) ;; ------------------------------------------------------------ (test "Error in resource allocation" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%")))) (b (compensate (format #t "throwing from allocation 2...~%") (throw 'misc-error) (with (format #t "compensation 2~%")))) (c (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))))) (format #t "Ciao!~%"))) ;; ------------------------------------------------------------ (test "Throwing from the body and error in compensation form" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensation 1~%")))) (b (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "throwing from compensation 2...~%") (throw 'nested-error)))) (c (compensate (format #t "allocation 3~%") (+ 5 6) (with (format #t "compensation 3~%"))))) (format #t "throwing from body...~%") (throw 'misc-error))) (test "Let, bindings" (let-compensations* ((a (compensate (format #t "allocation 1~%") (+ 1 2) (with (format #t "compensating 1: ~A~%" a)))) (b (compensate (format #t "allocation 2~%") (+ 3 4) (with (format #t "compensating 2: ~A~%" b))))) (format #t "throwing from body...~%") (throw 'this-error))) ;;; end of file