devops (with-output-log): Handle errors to ensure log is flushed.

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 1c65e84d1216fd952cd96571dcff6e4b82ac4c71..05454270b40633119a58325b1481bf662483a4c6 100644 (file)
--- a/src/devops/build.scm
+++ b/src/devops/build.scm
@@ -250,14 +250,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
                  0))))))))))
 
 (define (with-output-log filename thunk)
-  (call-with-output-file filename
-    (lambda (out)
-      (dynamic-wind
-       (lambda () unspecific)
-       (lambda () (with-output-to-port out thunk))
-       (lambda ()
-        (flush-output out)
-        (set-file-modes! filename #o444))))))
+  (let ((value
+        (call-with-current-continuation
+         (lambda (throw)
+           (call-with-output-file filename
+             (lambda (out)
+               (bind-condition-handler (list condition-type:serious-condition
+                                             condition-type:simple-condition)
+                   (named-lambda (log-condition-handler condition)
+                     (write-condition-report condition out)
+                     (newline out)
+                     (close-port out)
+                     (throw condition))
+                 (lambda ()
+                   (with-output-to-port out thunk)))))
+           #f))))
+    (set-file-modes! filename #o444)
+    (if (condition? value)
+       (error value))))
 
 (define (log-timestamp)
   (log "# "(universal-time->local-time-string (get-universal-time))"\n"))