clean up files on break

svn: r605

original commit: a42ef53b8483f5faed6e0eeaceac7a38637f7339

collects/mzlib/cm.ss

@@ -53,18 +53,43 @@
         ((eq? 'relative base) mode)
         (else (build-path base mode)))))
 
+  ;; with-compile-output : path (output-port -> alpha) -> alpha
+  ;;  Open path for writing, and arranges to delete path if there's
+  ;;  an exception. Breaks are managed so that the port is reliably
+  ;;  closed and the file is reliably deleted if there's a break
+  (define (with-compile-output path proc)
+    (let ([bp (current-break-parameterization)])
+      (with-handlers ([void (lambda (exn)
+			      ;; Attempt to delete, but give up if it
+			      ;;  doesn't work:
+			      (with-handlers ([exn:fail:filesystem? void])
+				(trace-printf "deleting: ~a" path)
+				(delete-file path))
+			      (raise exn))])
+	(let ([out (open-output-file path 'truncate/replace)])
+	  (dynamic-wind
+	      void
+	      (lambda ()
+		(call-with-break-parameterization
+		 bp
+		 (lambda ()
+		   (proc out))))
+	      (lambda ()
+		(close-output-port out)))))))
+
   (define (write-deps code mode path external-deps)
     (let ((dep-path (bytes->path
 		     (bytes-append (get-compilation-path mode path) #".dep")))
           (deps (get-deps code path)))
-      (let ((op (open-output-file dep-path 'replace)))
+      (with-compile-output 
-        (write (cons (version)
+       dep-path
-		     (append (map plthome-ify deps)
+       (lambda (op)
-			     (map (lambda (x) (plthome-ify (cons 'ext x)))
+	 (write (cons (version)
-                                  external-deps)))
+		      (append (map plthome-ify deps)
-	       op)
+			      (map (lambda (x) (plthome-ify (cons 'ext x)))
-        (newline op)
+				   external-deps)))
-        (close-output-port op))))
+		op)
+	 (newline op)))))
 
   (define (touch path)
     (close-output-port (open-output-file path 'append)))
@@ -74,9 +99,10 @@
       (delete-file zo-name))
     (let ([fail-path (bytes->path
 		      (bytes-append (get-compilation-path mode path) #".fail"))])
-      (let ([p (open-output-file fail-path 'truncate/replace)])
+      (with-compile-output 
-	(display reason p)
+       fail-path
-	(close-output-port p)))
+       (lambda (p)
+	 (display reason p))))
     (trace-printf "failure"))
 
   (define (compile-zo mode path)
@@ -107,28 +133,30 @@
                    [code-dir (get-code-dir mode path)])
               (if (not (directory-exists? code-dir))
                 (make-directory* code-dir))
-              (let ((out (open-output-file zo-name 'replace)))
+	      (with-compile-output
-                (with-handlers ((exn:fail?
+	       zo-name
-                                 (lambda (ex) (compilation-failure mode path zo-name #f (exn-message ex)))))
+	       (lambda (out)
-                  (dynamic-wind
+		 (with-handlers ((exn:fail?
-                    void
+				  (lambda (ex) (compilation-failure mode path zo-name #f (exn-message ex)))))
-                    (lambda () (write code out))
+		   (write code out))
-                    (lambda () (close-output-port out)))))
+		 ;; redundant, but close as early as possible:
-              (let ([ss-sec (file-or-directory-modify-seconds path)]
+		 (close-output-port out)
-                    [zo-sec (if (file-exists? zo-name)
+		 ;; Note that we check time and write .deps before returning from with-compile-output...
-				(file-or-directory-modify-seconds zo-name)
+		 (let ([ss-sec (file-or-directory-modify-seconds path)]
-				+inf.0)])
+		       [zo-sec (if (file-exists? zo-name)
-                (when (< zo-sec ss-sec)
+				   (file-or-directory-modify-seconds zo-name)
-                  (error 'compile-zo
+				   +inf.0)])
-                         "date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a"
+		   (when (< zo-sec ss-sec)
-                         zo-name
+		     (error 'compile-zo
-                         (format-date (seconds->date zo-sec))
+			    "date for newly created .zo file (~a @ ~a) is before source-file date (~a @ ~a)~a"
-                         path
+			    zo-name
-                         (format-date (seconds->date ss-sec))
+			    (format-date (seconds->date zo-sec))
-                         (if (> ss-sec (current-seconds))
+			    path
-                           ", which appears to be in the future"
+			    (format-date (seconds->date ss-sec))
-                           ""))))
+			    (if (> ss-sec (current-seconds))
-              (write-deps code mode path external-deps)))])))
+				", which appears to be in the future"
+				""))))
+		 (write-deps code mode path external-deps)))))])))
     (trace-printf "end compile: ~a" path))
 
   (define (format-date date)