From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Tue, 25 Apr 2017 21:03:38 +0000 (-0700)
Subject: Add with-temporary-file.
X-Git-Tag: mit-scheme-pucked-9.2.12~153^2~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b3acabd3ba03a36709bdfbb554fced1f399624db;p=mit-scheme.git

Add with-temporary-file.

This is basically call-with-temporary-file-pathname except it takes
the pathname and does not touch the file (allowing e.g. open-
exclusive-output-file to create it).  Also, optimize deallocate-
temporary-file for the case when the temporary file is already gone
(e.g. renamed into place).
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5082e5c46..95bc23913 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -675,6 +675,7 @@ USA.
 	  string->mime-type
 	  string-is-mime-token?
 	  string-is-mime-type?
+	  with-temporary-file
 	  write-mime-type)
   (initialization (initialize-package!)))
 
diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 619ed9888..0bca2af51 100644
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -206,6 +206,17 @@ USA.
      (lambda () (receiver pathname))
      (lambda () (deallocate-temporary-file pathname)))))
 
+(define (with-temporary-file pathname thunk)
+  (dynamic-wind
+   (lambda ()
+     (let ((updater (fixed-objects-updater 'files-to-delete))
+	   (string (string-for-primitive (->namestring pathname))))
+       (with-files-to-delete-locked
+	(lambda ()
+	  (updater (lambda (filenames) (cons string filenames)))))))
+   thunk
+   (lambda () (deallocate-temporary-file pathname))))
+
 (define files-to-delete-mutex)
 
 (define (with-files-to-delete-locked thunk)
@@ -226,7 +237,8 @@ USA.
 		   #t)))))))
 
 (define (deallocate-temporary-file pathname)
-  (delete-file-no-errors pathname)
+  (if (file-exists? pathname)
+      (delete-file-no-errors pathname))
   (let ((updater (fixed-objects-updater 'files-to-delete))
 	(filename (string-for-primitive (->namestring pathname))))
     (with-files-to-delete-locked