From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 9 Nov 1993 04:31:43 +0000 (+0000)
Subject: These changes require microcode version 11.145 or later.
X-Git-Tag: 20090517-FFI~7568
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cdacd99e6c971924783620534824e4994d9fe692;p=mit-scheme.git

These changes require microcode version 11.145 or later.

Reimplement handling of temporary files to update list in fixed
objects vector; this list tells the microcode that the files should be
deleted when Scheme is killed.

Additionally, change the handling of ".bci" file expansion to use the
new temporary file mechanism.  The expander now accepts a third value
for *SAVE-UNCOMPRESSED-FILES?* which says to expand the file into a
temporary file that is deleted (by the GC) after it has not been used
in a while, or when Scheme is killed.  This new option is now the
default, and the timeout for these temporary files defaults to five
minutes.
---

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index 6b4d9e470..6b10f6c63 100644
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.20 1993/09/07 21:56:27 gjr Exp $
+$Id: dosprm.scm,v 1.21 1993/11/09 04:31:37 cph Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -74,33 +74,37 @@ MIT in each case. |#
 		(directory-namestring pathname)
 		2))))))
 
-(define (call-with-temporary-filename receiver)
-  (let find-eligible-directory
-      ((eligible-directories 
-	(let ((tmp (or (get-environment-variable "TEMP")
-		       (get-environment-variable "TMP")))
-	      (others '("/tmp" "c:/" "." "/")))
-	  (if (not tmp) others (cons tmp others)))))
-    (if (null? eligible-directories)
-	(error "Can't locate directory for temporary file")
-	(let ((dir (->namestring
-		    (pathname-as-directory
-		     (merge-pathnames (car eligible-directories))))))
-	  (if (and (file-directory? dir) (file-writable? dir))
-	      (let ((base-name (string-append dir "_scm_tmp.")))
-		(let unique-file ((ext 0))
-		  (let ((name (string-append base-name (number->string ext))))
-		    (if (or (file-exists? name) (not (file-touch name)))
-			(if (fix:> ext 999) ; don't get rediculous here
-			    (error "Cannot find unique temp file name"
-				   base-name)
-			    (unique-file (fix:+ ext 1)))
-			(dynamic-wind
-			 (lambda () unspecific)
-			 (lambda () (receiver name))
-			 (lambda () (if (file-exists? name)
-					(delete-file name))))))))
-	      (find-eligible-directory (cdr eligible-directories)))))))
+(define (temporary-file-pathname)
+  (let ((root (merge-pathnames "_scm_tmp" (temporary-directory-pathname))))
+    (let loop ((ext 0))
+      (let ((pathname (pathname-new-type root (number->string ext))))
+	(if (allocate-temporary-file pathname)
+	    pathname
+	    (begin
+	      (if (> ext 999)
+		  (error "Can't find unique temporary pathname:" root))
+	      (loop (+ ext 1))))))))
+
+(define (temporary-directory-pathname)
+  (let ((try-directory
+	 (lambda (directory)
+	   (let ((directory
+		  (pathname-as-directory (merge-pathnames directory))))
+	     (and (file-directory? directory)
+		  (file-writable? directory)
+		  directory)))))
+    (let ((try-variable
+	   (lambda (name)
+	     (let ((value (get-environment-variable name)))
+	       (and value
+		    (try-directory value))))))
+      (or (try-variable "TEMP")
+	  (try-variable "TMP")
+	  (try-directory "/tmp")
+	  (try-directory "c:/")
+	  (try-directory ".")
+	  (try-directory "/")
+	  (error "Can't find temporary directory.")))))
 
 (define (file-attributes filename)
   ((ucode-primitive file-attributes 1)
diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm
index 401e2bc12..02ccc9d4e 100644
--- a/v7/src/runtime/infutl.scm
+++ b/v7/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.47 1993/07/28 03:42:02 cph Exp $
+$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -38,8 +38,6 @@ MIT in each case. |#
 (declare (usual-integrations))
 (declare (integrate-external "infstr" "char"))
 
-(define *save-uncompressed-files?* true)
-
 (define (initialize-package!)
   (set! special-form-procedure-names
 	`((,lambda-tag:unnamed . LAMBDA)
@@ -49,7 +47,11 @@ MIT in each case. |#
 	  (,lambda-tag:fluid-let . FLUID-LET)
 	  (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
   (set! blocks-with-memoized-debugging-info (make-population))
-  (add-secondary-gc-daemon! discard-debugging-info!))
+  (add-secondary-gc-daemon! discard-debugging-info!)
+  (initialize-uncompressed-files!)
+  (add-event-receiver! event:after-restore initialize-uncompressed-files!)
+  (add-event-receiver! event:before-exit delete-uncompressed-files!)
+  (add-gc-daemon! clean-uncompressed-files!))
 
 (define (compiled-code-block/dbg-info block demand-load?)
   (let ((old-info (compiled-code-block/debugging-info block)))
@@ -96,12 +98,23 @@ MIT in each case. |#
   (let ((pathname (merge-pathnames filename)))
     (if (file-exists? pathname)
 	(fasload-loader (->namestring pathname))
-	(find-alternate-file-type
-	 pathname
-	 `(("inf" . ,fasload-loader)
-	   ("bif" . ,fasload-loader)
-	   ("bci" . ,(lambda (pathname)
-		       (compressed-loader pathname "bif"))))))))
+	(find-alternate-file-type pathname
+				  `(("inf" . ,fasload-loader)
+				    ("bif" . ,fasload-loader)
+				    ("bci" . ,(compressed-loader "bif")))))))
+
+(define (find-alternate-file-type base-pathname alist)
+  (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x)))
+    (if (null? left)
+	(receiver file)
+	(let ((file* (pathname-new-type base-pathname (caar left)))
+	      (receiver* (cdar left)))
+	  (if (not (file-exists? file*))
+	      (loop (cdr left) time file receiver)
+	      (let ((time* (file-modification-time-direct file*)))
+		(if (> time* time)
+		    (loop (cdr left) time* file* receiver*)
+		    (loop (cdr left) time file receiver))))))))
 
 (define (memoize-debugging-info! block dbg-info)
   (without-interrupts
@@ -404,7 +417,7 @@ MIT in each case. |#
 			    (loop (cdr types))))))))))
     (and pathname
 	 (if (equal? "bcs" (pathname-type pathname))
-	     (compressed-loader pathname "bsm")
+	     ((compressed-loader "bsm") pathname)
 	     (fasload-loader pathname)))))
 
 (define (process-bsym-filename name)
@@ -550,6 +563,59 @@ MIT in each case. |#
 		      (vector-set! cp-table cp bp)
 		      (loop nbp ncp))))))))))
 
+(define (fasload-loader filename)
+  (call-with-current-continuation
+    (lambda (if-fail)
+      (bind-condition-handler (list condition-type:fasload-band)
+        (lambda (condition) condition (if-fail false))
+        (lambda () (fasload filename true))))))
+
+(define (compressed-loader uncompressed-type)
+  (lambda (compressed-file)
+    (lookup-uncompressed-file compressed-file fasload-loader
+      (lambda ()
+	(let ((load-compressed
+	       (lambda (temporary-file)
+		 (call-with-current-continuation
+		  (lambda (k)
+		    (uncompress-internal compressed-file
+					 temporary-file
+					 (lambda (message . irritants)
+					   message irritants
+					   (k #f)))
+		    (fasload-loader temporary-file))))))
+	  (case *save-uncompressed-files?*
+	    ((#F)
+	     (call-with-temporary-file-pathname load-compressed))
+	    ((AUTOMATIC)
+	     (call-with-uncompressed-file-pathname compressed-file
+						   load-compressed))
+	    (else
+	     (call-with-temporary-file-pathname
+	      (lambda (temporary-file)
+		(let ((result (load-compressed temporary-file))
+		      (uncompressed-file
+		       (pathname-new-type compressed-file uncompressed-type)))
+		  (delete-file-no-errors uncompressed-file)
+		  (if (call-with-current-continuation
+		       (lambda (k)
+			 (bind-condition-handler
+			     (list condition-type:file-error
+				   condition-type:port-error)
+			     (lambda (condition) condition (k #t))
+			   (lambda ()
+			     (rename-file temporary-file uncompressed-file)
+			     #f))))
+		      (call-with-current-continuation
+		       (lambda (k)
+			 (bind-condition-handler
+			     (list condition-type:file-error
+				   condition-type:port-error)
+			     (lambda (condition) condition (k unspecific))
+			   (lambda ()
+			     (copy-file temporary-file uncompressed-file))))))
+		  result))))))))))
+
 (define (uncompress-internal ifile ofile if-fail)
   (call-with-binary-input-file (merge-pathnames ifile)
     (lambda (input)			       
@@ -557,62 +623,76 @@ MIT in each case. |#
 	     (marker-size (string-length file-marker))
 	     (actual-marker (make-string marker-size)))
 	;; This may get more hairy as we up versions
-	(if (and (fix:= (uncompress-read-substring
-			 input actual-marker 0 marker-size)
+	(if (and (fix:= (uncompress-read-substring input
+						   actual-marker 0 marker-size)
 			marker-size)
 		 (string=? file-marker actual-marker))
 	    (call-with-binary-output-file (merge-pathnames ofile)
    	      (lambda (output)					  
 		(let ((size (file-attributes/length (file-attributes ifile))))
 		  (uncompress-ports input output (fix:* size 2)))))
-	    (if-fail "Not a recognized compressed file" ifile))))))
-
-(define (find-alternate-file-type base-pathname exts/receivers)
-  (let find-loop ((left exts/receivers)
-		  (time 0)
-		  (file false)
-		  (handler identity-procedure))
-			     
-    (if (null? left)
-	(handler file)
-	(let ((file* (pathname-new-type base-pathname (caar left)))
-	      (handler* (cdar left)))
-	  (if (not (file-exists? file*))
-	      (find-loop (cdr left) time file handler)
-	      (let ((time* (file-modification-time-direct file*)))
-		(if (> time* time)
-		    (find-loop (cdr left) time* file* handler*)
-		    (find-loop (cdr left) time file handler))))))))
-
-(define (fasload-loader filename)
-  (call-with-current-continuation
-    (lambda (if-fail)
-      (bind-condition-handler (list condition-type:fasload-band)
-        (lambda (condition) condition (if-fail false))
-        (lambda () (fasload filename true))))))
+	    (if-fail "Not a recognized compressed file:" ifile))))))
+
+(define (lookup-uncompressed-file compressed-file if-found if-not-found)
+  (dynamic-wind
+   (lambda ()
+     (set-car! uncompressed-files (+ (car uncompressed-files) 1)))
+   (lambda ()
+     (let loop ((entries (cdr uncompressed-files)))
+       (cond ((null? entries)
+	      (if-not-found))
+	     ((and (pathname=? (caar entries) compressed-file)
+		   (cddar entries))
+	      (dynamic-wind
+	       (lambda () unspecific)
+	       (lambda () (if-found (cadar entries)))
+	       (lambda () (set-cdr! (cdar entries) (real-time-clock)))))
+	     (else
+	      (loop (cdr entries))))))
+   (lambda ()
+     (set-car! uncompressed-files (- (car uncompressed-files) 1)))))
+
+(define (call-with-uncompressed-file-pathname compressed-file receiver)
+  (let ((temporary-file (temporary-file-pathname)))
+    (let ((entry
+	   (cons compressed-file
+		 (cons temporary-file (real-time-clock)))))
+      (dynamic-wind
+       (lambda () unspecific)
+       (lambda ()
+	 (without-interrupts
+	  (lambda ()
+	    (set-cdr! uncompressed-files
+		      (cons entry (cdr uncompressed-files)))))
+	 (receiver temporary-file))
+       (lambda ()
+	 (set-cdr! (cdr entry) (real-time-clock)))))))
+
+(define (delete-uncompressed-files!)
+  (do ((entries (cdr uncompressed-files) (cdr entries)))
+      ((null? entries) unspecific)
+    (deallocate-temporary-file (cadar entries))))
+
+(define (clean-uncompressed-files!)
+  (if (= 0 (car uncompressed-files))
+      (let ((time (real-time-clock)))
+	(let loop
+	    ((entries (cdr uncompressed-files))
+	     (prev uncompressed-files))
+	  (if (not (null? entries))
+	      (if (or (not (cddar entries))
+		      (< (- time (cddar entries))
+			 *uncompressed-file-lifetime*))
+		  (loop (cdr entries) entries)
+		  (begin
+		    (set-cdr! prev (cdr entries))
+		    (deallocate-temporary-file (cadar entries))
+		    (loop (cdr entries) prev))))))))
+
+(define (initialize-uncompressed-files!)
+  (set! uncompressed-files (list 0))
+  unspecific)
 
-(define (compressed-loader compressed-filename uncompressed-type)
-  (let ((core
-	 (lambda (uncompressed-filename)
-	   (call-with-current-continuation
-	    (lambda (if-fail)
-	      (uncompress-internal compressed-filename uncompressed-filename
-				   (lambda (message . irritants)
-				     message irritants
-				     (if-fail false)))
-	      (fasload-loader uncompressed-filename))))))
-
-    (call-with-temporary-filename
-     (if (not *save-uncompressed-files?*)
-	 core
-	 (lambda (temp-file)
-	   (let ((result (core temp-file)))
-	     (let ((new-file
-		    (pathname-new-type compressed-filename uncompressed-type))
-		   (dir (directory-pathname-as-file compressed-filename)))
-	       (if (file-writable? dir)
-		   (begin
-		     (if (file-exists? new-file)
-			 (delete-file new-file))
-		     (copy-file temp-file new-file)))
-	       result)))))))
\ No newline at end of file
+(define *save-uncompressed-files?* 'AUTOMATIC)
+(define *uncompressed-file-lifetime* 300000)
+(define uncompressed-files)
\ No newline at end of file
diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 0d677be70..3bed07d15 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.9 1993/11/06 21:36:53 cph Exp $
+$Id: sfile.scm,v 14.10 1993/11/09 04:31:40 cph Exp $
 
 Copyright (c) 1988-93 Massachusetts Institute of Technology
 
@@ -97,4 +97,41 @@ MIT in each case. |#
 			     n-read))))))))
        (lambda ()
 	 (if output-channel (channel-close output-channel))
-	 (if input-channel (channel-close input-channel)))))))
\ No newline at end of file
+	 (if input-channel (channel-close input-channel)))))))
+
+(define (call-with-temporary-filename receiver)
+  (call-with-temporary-file-pathname
+   (lambda (pathname)
+     (receiver (->namestring pathname)))))
+
+(define (call-with-temporary-file-pathname receiver)
+  (let ((pathname (temporary-file-pathname)))
+    (dynamic-wind
+     (lambda () unspecific)
+     (lambda () (receiver pathname))
+     (lambda () (deallocate-temporary-file pathname)))))
+
+(define (allocate-temporary-file pathname)
+  (and (not (file-exists? pathname))
+       (let ((objects (get-fixed-objects-vector))
+	     (slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
+	     (filename (->namestring pathname)))
+	 (without-interrupts
+	  (lambda ()
+	    (and (file-touch pathname)
+		 (begin
+		   (vector-set! objects slot
+				(cons filename (vector-ref objects slot)))
+		   ((ucode-primitive set-fixed-objects-vector! 1) objects)
+		   #t)))))))
+
+(define (deallocate-temporary-file pathname)
+  (delete-file-no-errors pathname)
+  (let ((objects (get-fixed-objects-vector))
+	(slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
+	(filename (->namestring pathname)))
+    (without-interrupts
+     (lambda ()
+       (vector-set! objects slot
+		    (delete! filename (vector-ref objects slot)))
+       ((ucode-primitive set-fixed-objects-vector! 1) objects)))))
\ No newline at end of file
diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index efd03063f..2ab887f1c 100644
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.25 1993/07/27 00:46:19 cph Exp $
+$Id: unxprm.scm,v 1.26 1993/11/09 04:31:41 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -73,35 +73,41 @@ MIT in each case. |#
 		(directory-namestring pathname)
 		2))))))
 
-(define (call-with-temporary-filename receiver)
-  (let find-eligible-directory
-      ((eligible-directories 
-	(let ((tmp (or (get-environment-variable "TEMP")
-		       (get-environment-variable "TMP")))
-	      (others '("." "/tmp" "/usr/tmp")))
-	  (if (not tmp) others (cons tmp others)))))
-    (if (null? eligible-directories)
-	(error "Can't locate directory for temporary file")
-	(let ((dir (->namestring
-		    (pathname-as-directory
-		     (merge-pathnames (car eligible-directories))))))
-	  (if (and (file-directory? dir) (file-writable? dir))
-	      (let ((base-name
-		     (string-append dir "_" (unix/current-user-name) "_scm")))
-		(let unique-file ((ext 0))
-		  (let ((name (string-append base-name (number->string ext))))
-		    (if (or (file-exists? name)
-			    (not (file-touch name)))
-			(if (fix:> ext 999) ; don't get rediculous here
-			    (error "Cannot find unique temp file name"
-				   base-name)
-			    (unique-file (fix:+ ext 1)))
-			(dynamic-wind
-			 (lambda () unspecific)
-			 (lambda () (receiver name))
-			 (lambda () (if (file-exists? name)
-					(delete-file name))))))))
-	      (find-eligible-directory (cdr eligible-directories)))))))
+(define (temporary-file-pathname)
+  (let ((root
+	 (merge-pathnames
+	  (string-append "sch"
+			 (string-pad-left (number->string (unix/current-pid))
+					  6
+					  #\0))
+	  (temporary-directory-pathname))))
+    (let loop ((ext 0))
+      (let ((pathname (pathname-new-type root (number->string ext))))
+	(if (allocate-temporary-file pathname)
+	    pathname
+	    (begin
+	      (if (> ext 999)
+		  (error "Can't find unique temporary pathname:" root))
+	      (loop (+ ext 1))))))))
+
+(define (temporary-directory-pathname)
+  (let ((try-directory
+	 (lambda (directory)
+	   (let ((directory
+		  (pathname-as-directory (merge-pathnames directory))))
+	     (and (file-directory? directory)
+		  (file-writable? directory)
+		  directory)))))
+    (let ((try-variable
+	   (lambda (name)
+	     (let ((value (get-environment-variable name)))
+	       (and value
+		    (try-directory value))))))
+      (or (try-variable "TEMP")
+	  (try-variable "TMP")
+	  (try-directory "/tmp")
+	  (try-directory "/usr/tmp")
+	  (error "Can't find temporary directory.")))))
 
 (define (file-attributes-direct filename)
   ((ucode-primitive file-attributes 1)
@@ -232,6 +238,9 @@ MIT in each case. |#
   (or ((ucode-primitive gid->string 1) gid)
       (number->string gid 10)))
 
+(define-integrable unix/current-pid
+  (ucode-primitive current-pid 0))
+
 (define-integrable unix/system
   (ucode-primitive system 1))
 
diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index a7ac052bd..9d5d84602 100644
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: version.scm,v 14.165 1993/10/21 11:49:56 cph Exp $
+$Id: version.scm,v 14.166 1993/11/09 04:31:43 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
 		     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 165))
+  (add-identification! "Runtime" 14 166))
 
 (define microcode-system)
 
diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm
index 401e2bc12..02ccc9d4e 100644
--- a/v8/src/runtime/infutl.scm
+++ b/v8/src/runtime/infutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: infutl.scm,v 1.47 1993/07/28 03:42:02 cph Exp $
+$Id: infutl.scm,v 1.48 1993/11/09 04:31:38 cph Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -38,8 +38,6 @@ MIT in each case. |#
 (declare (usual-integrations))
 (declare (integrate-external "infstr" "char"))
 
-(define *save-uncompressed-files?* true)
-
 (define (initialize-package!)
   (set! special-form-procedure-names
 	`((,lambda-tag:unnamed . LAMBDA)
@@ -49,7 +47,11 @@ MIT in each case. |#
 	  (,lambda-tag:fluid-let . FLUID-LET)
 	  (,lambda-tag:make-environment . MAKE-ENVIRONMENT)))
   (set! blocks-with-memoized-debugging-info (make-population))
-  (add-secondary-gc-daemon! discard-debugging-info!))
+  (add-secondary-gc-daemon! discard-debugging-info!)
+  (initialize-uncompressed-files!)
+  (add-event-receiver! event:after-restore initialize-uncompressed-files!)
+  (add-event-receiver! event:before-exit delete-uncompressed-files!)
+  (add-gc-daemon! clean-uncompressed-files!))
 
 (define (compiled-code-block/dbg-info block demand-load?)
   (let ((old-info (compiled-code-block/debugging-info block)))
@@ -96,12 +98,23 @@ MIT in each case. |#
   (let ((pathname (merge-pathnames filename)))
     (if (file-exists? pathname)
 	(fasload-loader (->namestring pathname))
-	(find-alternate-file-type
-	 pathname
-	 `(("inf" . ,fasload-loader)
-	   ("bif" . ,fasload-loader)
-	   ("bci" . ,(lambda (pathname)
-		       (compressed-loader pathname "bif"))))))))
+	(find-alternate-file-type pathname
+				  `(("inf" . ,fasload-loader)
+				    ("bif" . ,fasload-loader)
+				    ("bci" . ,(compressed-loader "bif")))))))
+
+(define (find-alternate-file-type base-pathname alist)
+  (let loop ((left alist) (time 0) (file #f) (receiver (lambda (x) x)))
+    (if (null? left)
+	(receiver file)
+	(let ((file* (pathname-new-type base-pathname (caar left)))
+	      (receiver* (cdar left)))
+	  (if (not (file-exists? file*))
+	      (loop (cdr left) time file receiver)
+	      (let ((time* (file-modification-time-direct file*)))
+		(if (> time* time)
+		    (loop (cdr left) time* file* receiver*)
+		    (loop (cdr left) time file receiver))))))))
 
 (define (memoize-debugging-info! block dbg-info)
   (without-interrupts
@@ -404,7 +417,7 @@ MIT in each case. |#
 			    (loop (cdr types))))))))))
     (and pathname
 	 (if (equal? "bcs" (pathname-type pathname))
-	     (compressed-loader pathname "bsm")
+	     ((compressed-loader "bsm") pathname)
 	     (fasload-loader pathname)))))
 
 (define (process-bsym-filename name)
@@ -550,6 +563,59 @@ MIT in each case. |#
 		      (vector-set! cp-table cp bp)
 		      (loop nbp ncp))))))))))
 
+(define (fasload-loader filename)
+  (call-with-current-continuation
+    (lambda (if-fail)
+      (bind-condition-handler (list condition-type:fasload-band)
+        (lambda (condition) condition (if-fail false))
+        (lambda () (fasload filename true))))))
+
+(define (compressed-loader uncompressed-type)
+  (lambda (compressed-file)
+    (lookup-uncompressed-file compressed-file fasload-loader
+      (lambda ()
+	(let ((load-compressed
+	       (lambda (temporary-file)
+		 (call-with-current-continuation
+		  (lambda (k)
+		    (uncompress-internal compressed-file
+					 temporary-file
+					 (lambda (message . irritants)
+					   message irritants
+					   (k #f)))
+		    (fasload-loader temporary-file))))))
+	  (case *save-uncompressed-files?*
+	    ((#F)
+	     (call-with-temporary-file-pathname load-compressed))
+	    ((AUTOMATIC)
+	     (call-with-uncompressed-file-pathname compressed-file
+						   load-compressed))
+	    (else
+	     (call-with-temporary-file-pathname
+	      (lambda (temporary-file)
+		(let ((result (load-compressed temporary-file))
+		      (uncompressed-file
+		       (pathname-new-type compressed-file uncompressed-type)))
+		  (delete-file-no-errors uncompressed-file)
+		  (if (call-with-current-continuation
+		       (lambda (k)
+			 (bind-condition-handler
+			     (list condition-type:file-error
+				   condition-type:port-error)
+			     (lambda (condition) condition (k #t))
+			   (lambda ()
+			     (rename-file temporary-file uncompressed-file)
+			     #f))))
+		      (call-with-current-continuation
+		       (lambda (k)
+			 (bind-condition-handler
+			     (list condition-type:file-error
+				   condition-type:port-error)
+			     (lambda (condition) condition (k unspecific))
+			   (lambda ()
+			     (copy-file temporary-file uncompressed-file))))))
+		  result))))))))))
+
 (define (uncompress-internal ifile ofile if-fail)
   (call-with-binary-input-file (merge-pathnames ifile)
     (lambda (input)			       
@@ -557,62 +623,76 @@ MIT in each case. |#
 	     (marker-size (string-length file-marker))
 	     (actual-marker (make-string marker-size)))
 	;; This may get more hairy as we up versions
-	(if (and (fix:= (uncompress-read-substring
-			 input actual-marker 0 marker-size)
+	(if (and (fix:= (uncompress-read-substring input
+						   actual-marker 0 marker-size)
 			marker-size)
 		 (string=? file-marker actual-marker))
 	    (call-with-binary-output-file (merge-pathnames ofile)
    	      (lambda (output)					  
 		(let ((size (file-attributes/length (file-attributes ifile))))
 		  (uncompress-ports input output (fix:* size 2)))))
-	    (if-fail "Not a recognized compressed file" ifile))))))
-
-(define (find-alternate-file-type base-pathname exts/receivers)
-  (let find-loop ((left exts/receivers)
-		  (time 0)
-		  (file false)
-		  (handler identity-procedure))
-			     
-    (if (null? left)
-	(handler file)
-	(let ((file* (pathname-new-type base-pathname (caar left)))
-	      (handler* (cdar left)))
-	  (if (not (file-exists? file*))
-	      (find-loop (cdr left) time file handler)
-	      (let ((time* (file-modification-time-direct file*)))
-		(if (> time* time)
-		    (find-loop (cdr left) time* file* handler*)
-		    (find-loop (cdr left) time file handler))))))))
-
-(define (fasload-loader filename)
-  (call-with-current-continuation
-    (lambda (if-fail)
-      (bind-condition-handler (list condition-type:fasload-band)
-        (lambda (condition) condition (if-fail false))
-        (lambda () (fasload filename true))))))
+	    (if-fail "Not a recognized compressed file:" ifile))))))
+
+(define (lookup-uncompressed-file compressed-file if-found if-not-found)
+  (dynamic-wind
+   (lambda ()
+     (set-car! uncompressed-files (+ (car uncompressed-files) 1)))
+   (lambda ()
+     (let loop ((entries (cdr uncompressed-files)))
+       (cond ((null? entries)
+	      (if-not-found))
+	     ((and (pathname=? (caar entries) compressed-file)
+		   (cddar entries))
+	      (dynamic-wind
+	       (lambda () unspecific)
+	       (lambda () (if-found (cadar entries)))
+	       (lambda () (set-cdr! (cdar entries) (real-time-clock)))))
+	     (else
+	      (loop (cdr entries))))))
+   (lambda ()
+     (set-car! uncompressed-files (- (car uncompressed-files) 1)))))
+
+(define (call-with-uncompressed-file-pathname compressed-file receiver)
+  (let ((temporary-file (temporary-file-pathname)))
+    (let ((entry
+	   (cons compressed-file
+		 (cons temporary-file (real-time-clock)))))
+      (dynamic-wind
+       (lambda () unspecific)
+       (lambda ()
+	 (without-interrupts
+	  (lambda ()
+	    (set-cdr! uncompressed-files
+		      (cons entry (cdr uncompressed-files)))))
+	 (receiver temporary-file))
+       (lambda ()
+	 (set-cdr! (cdr entry) (real-time-clock)))))))
+
+(define (delete-uncompressed-files!)
+  (do ((entries (cdr uncompressed-files) (cdr entries)))
+      ((null? entries) unspecific)
+    (deallocate-temporary-file (cadar entries))))
+
+(define (clean-uncompressed-files!)
+  (if (= 0 (car uncompressed-files))
+      (let ((time (real-time-clock)))
+	(let loop
+	    ((entries (cdr uncompressed-files))
+	     (prev uncompressed-files))
+	  (if (not (null? entries))
+	      (if (or (not (cddar entries))
+		      (< (- time (cddar entries))
+			 *uncompressed-file-lifetime*))
+		  (loop (cdr entries) entries)
+		  (begin
+		    (set-cdr! prev (cdr entries))
+		    (deallocate-temporary-file (cadar entries))
+		    (loop (cdr entries) prev))))))))
+
+(define (initialize-uncompressed-files!)
+  (set! uncompressed-files (list 0))
+  unspecific)
 
-(define (compressed-loader compressed-filename uncompressed-type)
-  (let ((core
-	 (lambda (uncompressed-filename)
-	   (call-with-current-continuation
-	    (lambda (if-fail)
-	      (uncompress-internal compressed-filename uncompressed-filename
-				   (lambda (message . irritants)
-				     message irritants
-				     (if-fail false)))
-	      (fasload-loader uncompressed-filename))))))
-
-    (call-with-temporary-filename
-     (if (not *save-uncompressed-files?*)
-	 core
-	 (lambda (temp-file)
-	   (let ((result (core temp-file)))
-	     (let ((new-file
-		    (pathname-new-type compressed-filename uncompressed-type))
-		   (dir (directory-pathname-as-file compressed-filename)))
-	       (if (file-writable? dir)
-		   (begin
-		     (if (file-exists? new-file)
-			 (delete-file new-file))
-		     (copy-file temp-file new-file)))
-	       result)))))))
\ No newline at end of file
+(define *save-uncompressed-files?* 'AUTOMATIC)
+(define *uncompressed-file-lifetime* 300000)
+(define uncompressed-files)
\ No newline at end of file