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

116
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
(require "file.ss"
"port.ss")
(provide compile-file)
;; (require compiler/src2src)
(define compile-file
(case-lambda
[(src)
(let-values ([(base name dir?) (split-path src)])
(let ([cdir (build-path
(if (symbol? base)
'same
base)
"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)
(let ([in (open-input-file src)])
(dynamic-wind
void
(lambda ()
(port-count-lines! in)
(with-handlers ([void
(lambda (exn)
(with-handlers ([void void])
(delete-file dest))
(raise exn))])
(let ([out (open-output-file dest 'truncate/replace)]
[ok? #f])
(let ([dir (let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory))))])
(parameterize ([current-load-relative-directory dir]
[current-write-relative-directory dir])
(dynamic-wind
void
(lambda ()
(let loop ()
(let ([r (read-syntax src in)])
(unless (eof-object? r)
(write (compile-syntax (filter (namespace-syntax-introduce r))) out)
(loop))))
(set! ok? #t))
(lambda ()
(close-output-port out)
(unless ok?
(with-handlers ([void void])
(delete-file dest))))))))))
(lambda () (close-input-port in))))
dest])))
(define compile-file
(case-lambda
[(src)
(define cdir (build-path (path-only src) "compiled"))
(make-directory* cdir)
(compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))]
[(src dest)
(compile-file src dest values)]
[(src dest filter)
(define in (open-input-file src))
(dynamic-wind
void
(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)
(dynamic-wind
void
(lambda ()
; XXX: This seems like it should be a library function named 'relative-path-only'
(define dir
(let-values ([(base name dir?) (split-path src)])
(if (eq? base 'relative)
(current-directory)
(path->complete-path base (current-directory)))))
(define out (open-output-file temp-filename #:exists 'truncate/replace))
(parameterize ([current-load-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
(lambda ()
(if (zero? count)
(set! count 1)
(error 'compile-file "filter function should not be re-entrant")))
(lambda ()
(for ([r (in-port (curry read-syntax src) in)])
(write (compile-syntax (filter (namespace-syntax-introduce r))) out))
(set! ok? #t))
(lambda ()
(close-output-port out)))))
(lambda ()
(if ok?
(rename-file-or-directory temp-filename dest)
(with-handlers ([exn:fail:filesystem? void])
(delete-file temp-filename))))))
(lambda () (close-input-port in)))
dest]))