73 lines
2.7 KiB
Scheme
73 lines
2.7 KiB
Scheme
#lang scheme/base
|
|
(require scheme/path
|
|
scheme/file
|
|
compiler/cm)
|
|
|
|
#|
|
|
|
|
All of this code runs on the user's parameterization/thread
|
|
|
|
|#
|
|
|
|
(provide build-and-load-zo-file)
|
|
|
|
(define (build-and-load-zo-file original-load/use-compiled-handler path mod)
|
|
(cond
|
|
[(or (not (filename-extension path))
|
|
(already-a-compiled-file? path))
|
|
;; if there is no extension, just give up.
|
|
;; if there is a compiled file that look up to date
|
|
;; in the usual place, use it.
|
|
(original-load/use-compiled-handler path mod)]
|
|
[else
|
|
;; otherwise do some managed compilation
|
|
(parameterize ([manager-skip-file-handler (λ (x)
|
|
(printf "considering ~s\n" x)
|
|
#f)])
|
|
(managed-compile-zo path))
|
|
(original-load/use-compiled-handler path mod)]))
|
|
|
|
(define (exists-and-is-newer? orig-path candidate-path)
|
|
(and (file-exists? candidate-path)
|
|
(< (file-or-directory-modify-seconds orig-path)
|
|
(file-or-directory-modify-seconds candidate-path))))
|
|
|
|
(define (already-a-compiled-file? path)
|
|
(let* ([filename (file-name-from-path path)]
|
|
[base (path-only path)]
|
|
[file-zo-name (and filename (compiled-name filename #".zo"))]
|
|
[fm (file-or-directory-modify-seconds path)]
|
|
[newer-exists?
|
|
(λ (pot-path)
|
|
(and (file-exists? pot-path)
|
|
(< fm (file-or-directory-modify-seconds pot-path))))])
|
|
(and file-zo-name
|
|
(ormap
|
|
(λ (c-f-p)
|
|
(or (newer-exists? (build-path base c-f-p file-zo-name))
|
|
(newer-exists? (build-path base
|
|
c-f-p
|
|
"native"
|
|
(system-library-subpath)
|
|
(compiled-name filename (system-type 'so-suffix))))))
|
|
(use-compiled-file-paths)))))
|
|
|
|
|
|
;; compiled-name : path [bytes] -> path or #f
|
|
;; returns #f if the path does not have an extension.
|
|
;; otherwise, returns an appropriately modified filename, extended with new-extension
|
|
(define (compiled-name path new-extension)
|
|
(let* ([extension (filename-extension path)]
|
|
[basename (and extension
|
|
(let ([pbs (path->bytes path)])
|
|
(subbytes pbs
|
|
0
|
|
(- (bytes-length pbs)
|
|
(bytes-length extension)
|
|
1 ;; extra one for '.' in there
|
|
))))])
|
|
(and basename
|
|
(bytes->path
|
|
(bytes-append basename #"_" extension new-extension)))))
|
|
|