suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Converting to scheme/base. Adding atomic renaming of compiled zos. Simplifying some parts with library functions. Using a low-tech continuation barrier, re: robby. Using define to reduce left creep. Adding commentary on design choices. Tested on Linux and Mac OS X. Based on code from Petey Aldous.

Browse Source 
svn: r17166
This commit is contained in:
Jay McCarthy 2009-12-02 20:45:59 +00:00
parent 7015edb070
commit ae7482d572
1 changed files with 61 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/mzlib/compile.ss
View File

@ -1,57 +1,63 @@
#lang scheme/base
(require scheme/function
scheme/path
scheme/file)
(provide compile-file)
(module compile mzscheme (define compile-file
(require "file.ss"
"port.ss")
(provide compile-file)
;; (require compiler/src2src)
(define compile-file
(case-lambda (case-lambda
[(src) [(src)
(let-values ([(base name dir?) (split-path src)]) (define cdir (build-path (path-only src) "compiled"))
(let ([cdir (build-path (make-directory* cdir)
(if (symbol? base) (compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))]
'same [(src dest)
base) (compile-file src dest values)]
"compiled")])
(unless (directory-exists? cdir)
(make-directory cdir))
(compile-file src (build-path cdir (path-add-suffix name #".zo")))))]
[(src dest) (compile-file src dest values)]
[(src dest filter) [(src dest filter)
(let ([in (open-input-file src)]) (define in (open-input-file src))
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(define ok? #f)
; This must be based on the path to dest. Renaming typically cannot be done
; atomically across file systems, so the temporary directory is not an option
; because it is often a ram disk. src (or dir below) couldn't be used because
; it may be on a different filesystem. Since dest must be a file path, this
; guarantees that the temp file is in the same directory. It would take a weird
; filesystem configuration to break that.
(define temp-filename (make-temporary-file "tmp~a" #f (path-only dest)))
(port-count-lines! in) (port-count-lines! in)
(with-handlers ([void (dynamic-wind
(lambda (exn) void
(with-handlers ([void void]) (lambda ()
(delete-file dest)) ; XXX: This seems like it should be a library function named 'relative-path-only'
(raise exn))]) (define dir
(let ([out (open-output-file dest 'truncate/replace)] (let-values ([(base name dir?) (split-path src)])
[ok? #f])
(let ([dir (let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative) (if (eq? base 'relative)
(current-directory) (current-directory)
(path->complete-path base (current-directory))))]) (path->complete-path base (current-directory)))))
(define out (open-output-file temp-filename #:exists 'truncate/replace))
(parameterize ([current-load-relative-directory dir] (parameterize ([current-load-relative-directory dir]
[current-write-relative-directory dir]) [current-write-relative-directory dir])
; Rather than installing a continuation barrier, we detect reinvocation.
; The only thing that can cause reinvocation is if the filter captures the
; continuation and communicates it externally.
(define count 0)
(dynamic-wind (dynamic-wind
void
(lambda () (lambda ()
(let loop () (if (zero? count)
(let ([r (read-syntax src in)]) (set! count 1)
(unless (eof-object? r) (error 'compile-file "filter function should not be re-entrant")))
(write (compile-syntax (filter (namespace-syntax-introduce r))) out) (lambda ()
(loop)))) (for ([r (in-port (curry read-syntax src) in)])
(write (compile-syntax (filter (namespace-syntax-introduce r))) out))
(set! ok? #t)) (set! ok? #t))
(lambda () (lambda ()
(close-output-port out) (close-output-port out)))))
(unless ok? (lambda ()
(with-handlers ([void void]) (if ok?
(delete-file dest)))))))))) (rename-file-or-directory temp-filename dest)
(lambda () (close-input-port in)))) (with-handlers ([exn:fail:filesystem? void])
dest]))) (delete-file temp-filename))))))
(lambda () (close-input-port in)))
dest]))