From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Wed, 13 Sep 2017 07:00:59 +0000 (-0700)
Subject: devops (with-output-log): Handle errors to ensure log is flushed.
X-Git-Tag: mit-scheme-pucked-9.2.12~67
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=593716d7b3879cfea0fe9b119cd946467be3a195;p=mit-scheme.git

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

diff --git a/src/devops/build.scm b/src/devops/build.scm
index 1c65e84d1..05454270b 100644
--- 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"))