by uriel.
When an exception is thrown: the stack unwinds and some mechanism must be used to release allocated resources that cannot be simply garbage collected. Some mechanisms (guile-guardian) requires asynchronous evaluation of cleanup code, other mechanisms (guile-compensation) require synchronous evaluation of cleanup code.
With synchronous cleanup code: what happens if the cleanup code itself throws an exception? If this second level exception is left going: it replaces the original one (first level), that is lost:
(catch #t
(lambda ()
(scm-error 'first-error 'here "first error" #f #f))
(lambda (key . args)
(scm-error 'second-error 'there "second error" #f #f)))
outputs:
ERROR: In procedure there: ERROR: second error
first-error is never reported. We rarely want this.
This page presents a Guile module that can be used to save informations about second level exceptions, for the case in which it is fine to try to go on reporting the first level error. With this module: second level exceptions can be reported later to the user or logged to a file or whatever.
A form that uses deferrec catches looks like this:
(with-deferred-catch an-error-key
(lambda ()
(body))
(lambda (key . args)
(deferred-catch another-error-key
(first-level-exceptions-handler)))
(lambda (stack key procname message other-args)
(second-level-exceptions-handler)))
the first three arguments to with-deferred-catch become the arguments to an invocation to the built in catch:
(catch an-error-key
(lambda ()
(body))
(lambda (key . args)
(deferred-catch another-error-key
(first-level-exceptions-handler))))
a deferred-catch form can appear any number of times in both the body and the synchronous exception handler: it expands to a catch invocation that wraps its body:
(catch another-error-key
(lambda ()
(first-level-exceptions-handler))
(lambda (key . args)
...))
and whose error handler enqueues exception's informations in a list handled by a fluid.
After the evaluation of the body and, if triggered, of the first level exception handler: the second level handler is invoked for each of the second level exceptions in the list. The arguments to the second level handler are:
the return value of make-stack evaluated in the expansion of deferred-catch;
the exception key;
the procedure name argument of scm-error or the string "<unknown procedure>" if throw key was used;
the formatted error message built from arguments to scm-error or the string "undescribed error" if {{{throw key}}} was used;
the additional argument of scm-error or #f if throw key was used.
(define-module (deferred-catch) #:export (*deferred-catches* with-deferred-catch deferred-catch)) (define *deferred-catches* (make-fluid)) (define-macro (with-deferred-catch KEY THUNK HANDLER DEFERRED-HANDLER) `(with-fluid* *deferred-catches* '() (lambda () (let* ((result (catch ,KEY ,THUNK ,HANDLER)) (current (fluid-ref *deferred-catches*))) (for-each (lambda (exc) (apply ,DEFERRED-HANDLER exc)) (fluid-ref *deferred-catches*)) result)))) (define-macro (deferred-catch KEY . FORMS) `(catch ,KEY (lambda () ,@FORMS) (lambda (key . args) (fluid-set! *deferred-catches* (cons (if (null? args) (list (make-stack #t) key "<unknown procedure>" "undescribed error" #f) (let ((procname (car args)) (message (cadr args)) (message-args (caddr args)) (other-args (cadddr args))) (list (make-stack #t 6) key procname (if message-args (apply format #f message message-args) message) other-args))) (fluid-ref *deferred-catches*))))))
;;; deferred-catch-test.scm -- (use-modules (deferred-catch)) (define-macro (test DESCR . FORMS) `(begin (format #t "~%* ~A:~%~%" ,DESCR) ,@FORMS)) ;; ------------------------------------------------------------ (test "No error" (with-deferred-catch #t (lambda () (format #t "ciao~%") (deferred-catch #t (format #t "ciao~%")) (format #t "ciao~%")) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred: key=~A~%" key)))) ;; ------------------------------------------------------------ (test "One deferred exception (scm-error)" (with-deferred-catch #t (lambda () (format #t "ciao~%") (deferred-catch #t (format #t "salve~%") (format #t "throwing exception...~%") (scm-error 'misc-error 'here "an error (~A ~A)" '(1 2) '(3 4))) (format #t "ciao~%")) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A, message=~S, args=~S~%" key message other-args) ;(display-backtrace stack (current-output-port)) ))) ;; ------------------------------------------------------------ (test "One deferred exception (throw)" (with-deferred-catch #t (lambda () (format #t "ciao~%") (deferred-catch #t (format #t "salve~%") (format #t "throwing exception...~%") (throw 'misc-error)) (format #t "ciao~%")) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A, message=~S, args=~S~%" key message other-args)))) ;; ------------------------------------------------------------ (test "Sync error" (with-deferred-catch #t (lambda () (format #t "ciao~%") (format #t "throwing exception...~%") (throw 'sync-error) (format #t "ciao~%")) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A~%" key)))) ;; ------------------------------------------------------------ (test "Sync error and one deferred exception (throw)" (with-deferred-catch #t (lambda () (format #t "ciao~%") (deferred-catch #t (format #t "salve~%") (format #t "throwing deferred exception...~%") (throw 'misc-error)) (format #t "throwing sync exception...~%") (throw 'sync-error)) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A, message=~S, args=~S~%" key message other-args)))) ;; ------------------------------------------------------------ (test "Sync error and one deferred exception (throw) in the sync handler" (with-deferred-catch #t (lambda () (format #t "ciao~%") (format #t "throwing sync exception...~%") (throw 'sync-error)) (lambda (key . args) (format #t "sync handler: ~A~%" key) (deferred-catch #t (format #t "ulla~%") (format #t "throwing deferred exception...~%") (throw 'misc-error))) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A, message=~S, args=~S~%" key message other-args)))) ;; ------------------------------------------------------------ (test "Sync error and two deferred exceptions (throw)" (with-deferred-catch #t (lambda () (format #t "ciao~%") (deferred-catch #t (format #t "salve~%") (format #t "throwing deferred exception...~%") (throw 'one-error)) (deferred-catch #t (format #t "salve~%") (format #t "throwing other deferred exception...~%") (throw 'two-error)) (format #t "throwing sync exception...~%") (throw 'sync-error)) (lambda (key . args) (format #t "sync handler: ~A~%" key)) (lambda (stack key procname message other-args) (format #t "deferred handler: key=~A, message=~S, args=~S~%" key message other-args)))) ;;; end of file