#| -*-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
(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.")))))
\f
(define (file-attributes filename)
((ucode-primitive file-attributes 1)
#| -*-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
(declare (usual-integrations))
(declare (integrate-external "infstr" "char"))
\f
-(define *save-uncompressed-files?* true)
-
(define (initialize-package!)
(set! special-form-procedure-names
`((,lambda-tag:unnamed . LAMBDA)
(,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)))
(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))))))))
\f
(define (memoize-debugging-info! block dbg-info)
(without-interrupts
(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)
(vector-set! cp-table cp bp)
(loop nbp ncp))))))))))
\f
+(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)
(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))))))
+\f
+(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
#| -*-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
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)))))))
+\f
+(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
#| -*-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
(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.")))))
\f
(define (file-attributes-direct filename)
((ucode-primitive file-attributes 1)
(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))
#| -*-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
'()))
(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)
#| -*-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
(declare (usual-integrations))
(declare (integrate-external "infstr" "char"))
\f
-(define *save-uncompressed-files?* true)
-
(define (initialize-package!)
(set! special-form-procedure-names
`((,lambda-tag:unnamed . LAMBDA)
(,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)))
(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))))))))
\f
(define (memoize-debugging-info! block dbg-info)
(without-interrupts
(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)
(vector-set! cp-table cp bp)
(loop nbp ncp))))))))))
\f
+(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)
(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))))))
+\f
+(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
projects / mit-scheme.git / commitdiff