diff options
author | Andy Wingo <wingo@pobox.com> | 2008-10-31 13:28:06 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-10-31 13:28:06 +0100 |
commit | 03fa04dfe13512d37e0f19ffd0e6c7f5db8f466f (patch) | |
tree | 7bdef93f2ff16c2e8abb2aaa2228d85cf919c53a /module/system/base/compile.scm | |
parent | 46ccd0bbf919b8b501355e0452deaee123057239 (diff) | |
download | guile-03fa04dfe13512d37e0f19ffd0e6c7f5db8f466f.tar.gz |
pass backtraces through the compiler
* module/system/base/compile.scm (call-with-nonlocal-exit-protect): New
helper, like unwind-protect but only for nonlocal exits.
(call-with-output-file/atomic): Use call-with-nonlocal-exit-protect so
that we don't mess up backtraces by catching all and then rethrowing.
Should fix this more comprehensively somewhere, though.
Diffstat (limited to 'module/system/base/compile.scm')
-rw-r--r-- | module/system/base/compile.scm | 30 |
1 files changed, 22 insertions, 8 deletions
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index c852660dd..d75dc3dcd 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -62,17 +62,31 @@ (define *current-language* (make-fluid)) +;; This is basically to avoid mucking with the backtrace. +(define (call-with-nonlocal-exit-protect thunk on-nonlocal-exit) + (let ((success #f) (entered #f)) + (dynamic-wind + (lambda () + (if entered + (error "thunk may only be entered once: ~a" thunk)) + (set! entered #t)) + (lambda () + (thunk) + (set! success #t)) + (lambda () + (if (not success) + (on-nonlocal-exit)))))) + (define (call-with-output-file/atomic filename proc) (let* ((template (string-append filename ".XXXXXX")) (tmp (mkstemp! template))) - (catch #t - (lambda () - (with-output-to-port tmp - (lambda () (proc (current-output-port)))) - (rename-file template filename)) - (lambda args - (delete-file template) - (apply throw args))))) + (call-with-nonlocal-exit-protect + (lambda () + (with-output-to-port tmp + (lambda () (proc (current-output-port)))) + (rename-file template filename)) + (lambda () + (delete-file template))))) (define (compile-file file . opts) (let ((comp (compiled-file-name file)) |