From 593716d7b3879cfea0fe9b119cd946467be3a195 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 13 Sep 2017 00:00:59 -0700 Subject: [PATCH] devops (with-output-log): Handle errors to ensure log is flushed. --- src/devops/build.scm | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) 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")) -- 2.25.1