From: Taylor R Campbell <campbell@mumble.net>
Date: Wed, 9 Jan 2019 03:46:15 +0000 (+0000)
Subject: Atomic write-to-temporary/rename-to-permanent so liarc is ^Cable.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~64
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4f6c2bf1e7ac38d8e4b62d95ca05aa428e2187bf;p=mit-scheme.git

Atomic write-to-temporary/rename-to-permanent so liarc is ^Cable.
---

diff --git a/src/compiler/machines/C/ctop.scm b/src/compiler/machines/C/ctop.scm
index 52603108c..fae70e10f 100644
--- a/src/compiler/machines/C/ctop.scm
+++ b/src/compiler/machines/C/ctop.scm
@@ -36,7 +36,7 @@ USA.
 
 (define (compiler-file-output compiler-output pathname)
   (let ((code (cdr (vector-ref compiler-output 1))))
-    (call-with-output-file pathname
+    (call-with-temporary-output-file pathname (directory-pathname pathname)
       (lambda (port)
 	(c:write-group code port)))
     (if compiler:invoke-c-compiler?
@@ -44,6 +44,21 @@ USA.
 		   (pathname-new-type pathname "o")
 		   (pathname-new-type pathname (c-output-extension))))))
 
+(define (call-with-temporary-output-file pathname directory receiver)
+  (let ((temporary (temporary-file-pathname directory))
+	(done? #f))
+    (dynamic-wind
+      (lambda ()
+	(if done?
+	    (error "Re-entry into temporary file creation is not allowed.")))
+      (lambda ()
+	(let ((result (call-with-output-file temporary receiver)))
+	  (rename-file temporary pathname)
+	  result))
+      (lambda ()
+	(set! done? #t)
+	(deallocate-temporary-file temporary)))))
+
 (define (compile-data-from-file object pathname)
   pathname				;ignore
   (let ((result