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.

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index c852660..d75dc3d 100644 (file)
--- 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))