summaryrefslogtreecommitdiff
path: root/module/system/base/compile.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-10-31 13:28:06 +0100
committerAndy Wingo <wingo@pobox.com>2008-10-31 13:28:06 +0100
commit03fa04dfe13512d37e0f19ffd0e6c7f5db8f466f (patch)
tree7bdef93f2ff16c2e8abb2aaa2228d85cf919c53a /module/system/base/compile.scm
parent46ccd0bbf919b8b501355e0452deaee123057239 (diff)
downloadguile-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.scm30
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))