168 lines
7.5 KiB
Racket
168 lines
7.5 KiB
Racket
(module modcode scheme/base
|
|
(require mzlib/port
|
|
mzlib/contract
|
|
"modread.ss")
|
|
|
|
(provide moddep-current-open-input-file
|
|
exn:get-module-code
|
|
exn:get-module-code?
|
|
exn:get-module-code-path
|
|
make-exn:get-module-code
|
|
get-module-code)
|
|
#;
|
|
;; Contracts don't yet play well with keyword arguments:
|
|
(provide/contract
|
|
[get-module-code ([path-string?]
|
|
[(and/c path-string? relative-path?)
|
|
(any/c . -> . any)
|
|
(or/c false/c (path? boolean? . -> . any))
|
|
any/c]
|
|
. opt-> .
|
|
any)])
|
|
|
|
(define moddep-current-open-input-file
|
|
(make-parameter open-input-file))
|
|
|
|
(define (resolve s)
|
|
(if (complete-path? s)
|
|
s
|
|
(let ([d (current-load-relative-directory)])
|
|
(if d (path->complete-path s d) s))))
|
|
|
|
(define (date>=? a bm)
|
|
(and a (let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
|
(file-or-directory-modify-seconds a))])
|
|
(or (and (not bm) am) (and am bm (>= am bm))))))
|
|
|
|
(define (read-one orig-path path src? read-src-syntax)
|
|
(let ([p ((moddep-current-open-input-file) path)])
|
|
(when src? (port-count-lines! p))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(let ([v (with-module-reading-parameterization
|
|
(lambda ()
|
|
;; In case we're reading a .zo, we need to set
|
|
;; the load-relative directory for unmarshaling
|
|
;; path literals.
|
|
(parameterize ([current-load-relative-directory
|
|
(let-values ([(base name dir?) (split-path orig-path)])
|
|
(if (path? base)
|
|
base
|
|
(current-directory)))])
|
|
(read-src-syntax path p))))])
|
|
(when (eof-object? v)
|
|
(error 'read-one
|
|
"empty file; expected a module declaration in: ~a" path))
|
|
(let* ([name (let-values ([(base name dir?) (split-path orig-path)])
|
|
(string->symbol
|
|
(bytes->string/utf-8
|
|
(path->bytes (path-replace-suffix name #""))
|
|
#\?)))]
|
|
[v (check-module-form v name path)])
|
|
(unless (eof-object? (read p))
|
|
(error 'read-one
|
|
"file has more than one expression; expected a module declaration only in: ~a"
|
|
path))
|
|
(if (and (syntax? v) (compiled-expression? (syntax-e v)))
|
|
(syntax-e v)
|
|
v))))
|
|
(lambda () (close-input-port p)))))
|
|
|
|
(define-struct (exn:get-module-code exn) (path))
|
|
|
|
(define (get-module-code path
|
|
#:sub-path [sub-path0 "compiled"]
|
|
#:compile [compile0 compile]
|
|
#:extension-handler [ext-handler0 #f]
|
|
[sub-path sub-path0] [compiler compile0] [extension-handler ext-handler0]
|
|
#:choose [choose (lambda (src zo so) #f)]
|
|
#:notify [notify void]
|
|
#:source-reader [read-src-syntax read-syntax]
|
|
#:rkt-try-ss? [rkt-try-ss? #t])
|
|
(unless (path-string? path)
|
|
(raise-type-error 'get-module-code "path or string (sans nul)" path))
|
|
(let*-values ([(orig-path) (resolve path)]
|
|
[(base orig-file dir?) (split-path path)]
|
|
[(main-file alt-file)
|
|
(if rkt-try-ss?
|
|
(let* ([b (path->bytes orig-file)]
|
|
[len (bytes-length b)])
|
|
(cond
|
|
[(and (len . >= . 4)
|
|
(bytes=? #".rkt" (subbytes b (- len 4))))
|
|
;; .rkt => try .rkt then .ss
|
|
(values orig-file
|
|
(bytes->path (bytes-append (subbytes b 0 (- len 4)) #".ss")))]
|
|
[else
|
|
;; No search path
|
|
(values orig-file #f)]))
|
|
(values orig-file #f))]
|
|
[(main-path) (if (eq? main-file orig-file)
|
|
orig-path
|
|
(build-path base main-file))]
|
|
[(alt-path) (and alt-file
|
|
(if (eq? alt-file orig-file)
|
|
orig-path
|
|
(build-path base alt-file)))]
|
|
[(base) (if (eq? base 'relative) 'same base)]
|
|
[(mode) (use-compiled-file-paths)])
|
|
(let* ([main-path-d (file-or-directory-modify-seconds orig-path #f (lambda () #f))]
|
|
[alt-path-d (and alt-path
|
|
(not main-path-d)
|
|
(file-or-directory-modify-seconds alt-path #f (lambda () #f)))]
|
|
[path-d (or main-path-d alt-path-d)]
|
|
[file (if alt-path-d alt-file main-file)]
|
|
[path (if alt-path-d alt-path main-path)]
|
|
[try-alt? (and (not alt-path-d) (not main-path-d))]
|
|
[get-so (lambda (file)
|
|
(build-path
|
|
base sub-path "native"
|
|
(system-library-subpath)
|
|
(path-add-suffix file (system-type 'so-suffix))))]
|
|
[zo (build-path base sub-path (path-add-suffix file #".zo"))]
|
|
[alt-zo (and try-alt?
|
|
(build-path base sub-path (path-add-suffix alt-file #".zo")))]
|
|
[so (get-so file)]
|
|
[alt-so (and try-alt? (get-so alt-file))]
|
|
[with-dir (lambda (t)
|
|
(parameterize ([current-load-relative-directory
|
|
(if (path? base)
|
|
base
|
|
(current-directory))])
|
|
(t)))]
|
|
[prefer (choose path zo so)])
|
|
(cond
|
|
;; Use .zo, if it's new enough
|
|
[(or (eq? prefer 'zo)
|
|
(and (not prefer)
|
|
(or (date>=? zo path-d)
|
|
(and try-alt?
|
|
(date>=? alt-zo path-d)))))
|
|
(notify zo)
|
|
(read-one path zo #f read-syntax)]
|
|
;; Maybe there's an .so? Use it only if we don't prefer source.
|
|
[(or (eq? prefer 'so)
|
|
(and (not prefer)
|
|
(or (date>=? so path-d)
|
|
(and try-alt?
|
|
(date>=? alt-so path-d)))))
|
|
(if extension-handler
|
|
(begin
|
|
(notify so)
|
|
(extension-handler so #f))
|
|
(raise (make-exn:get-module-code
|
|
(format "get-module-code: cannot use extension file; ~e" so)
|
|
(current-continuation-marks)
|
|
so)))]
|
|
;; Use source if it exists
|
|
[(or (eq? prefer 'src)
|
|
path-d)
|
|
(notify path)
|
|
(with-dir (lambda () (compiler (read-one orig-path path #t read-src-syntax))))]
|
|
;; Report a not-there error
|
|
[else (raise (make-exn:get-module-code
|
|
(format "get-module-code: no such file: ~e" orig-path)
|
|
(current-continuation-marks)
|
|
#f))])))))
|