Cosmetic restructuring of syntax/modcode.
This work is preparation for exporting more functionality from this module. Renamed variables for clarity and to eliminate shadowing. Turned lets into defines.
This commit is contained in:
Carl Eastlund
parent
7e8ab6b7c1
commit
85fc035f75
|
|
@ -1,226 +1,232 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
racket/list
|
||||
"modread.rkt")
|
||||
(require racket/contract/base
|
||||
racket/list
|
||||
"modread.rkt")
|
||||
|
||||
(provide moddep-current-open-input-file
|
||||
exn:get-module-code
|
||||
exn:get-module-code?
|
||||
exn:get-module-code-path
|
||||
make-exn:get-module-code)
|
||||
(provide moddep-current-open-input-file
|
||||
exn:get-module-code
|
||||
exn:get-module-code?
|
||||
exn:get-module-code-path
|
||||
make-exn:get-module-code)
|
||||
|
||||
(provide/contract
|
||||
[get-module-code (->* (path?)
|
||||
(#:roots
|
||||
(listof (or/c path? 'same))
|
||||
#:submodule-path
|
||||
(listof symbol?)
|
||||
#:sub-path
|
||||
(and/c path-string? relative-path?)
|
||||
(and/c path-string? relative-path?)
|
||||
#:compile (-> any/c any)
|
||||
(-> any/c any)
|
||||
#:extension-handler (or/c false/c (path? boolean? . -> . any))
|
||||
(or/c false/c (path? boolean? . -> . any))
|
||||
#:choose
|
||||
(path? path? path? . -> . (or/c (symbols 'src 'zo 'so) false/c))
|
||||
#:notify (any/c . -> . any)
|
||||
#:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?))
|
||||
#:rkt-try-ss? boolean?)
|
||||
any)])
|
||||
(provide/contract
|
||||
[get-module-code (->* (path?)
|
||||
(#:roots
|
||||
(listof (or/c path? 'same))
|
||||
#:submodule-path
|
||||
(listof symbol?)
|
||||
#:sub-path
|
||||
(and/c path-string? relative-path?)
|
||||
(and/c path-string? relative-path?)
|
||||
#:compile (-> any/c any)
|
||||
(-> any/c any)
|
||||
#:extension-handler (or/c false/c (path? boolean? . -> . any))
|
||||
(or/c false/c (path? boolean? . -> . any))
|
||||
#:choose
|
||||
(path? path? path? . -> . (or/c (symbols 'src 'zo 'so) false/c))
|
||||
#:notify (any/c . -> . any)
|
||||
#:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?))
|
||||
#:rkt-try-ss? boolean?)
|
||||
any)])
|
||||
|
||||
(define moddep-current-open-input-file
|
||||
(make-parameter open-input-file))
|
||||
(define moddep-current-open-input-file
|
||||
(make-parameter open-input-file))
|
||||
|
||||
(define (resolve s)
|
||||
(if (complete-path? s)
|
||||
(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 (date>=? a bm)
|
||||
(and a
|
||||
(let ([am (with-handlers ([exn:fail:filesystem? (lambda (x) #f)])
|
||||
(file-or-directory-modify-seconds a))])
|
||||
(and am (if bm (>= am bm) #t)))))
|
||||
|
||||
(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 (read-one orig-path path src? read-src-syntax)
|
||||
(define p ((moddep-current-open-input-file) path))
|
||||
(when src? (port-count-lines! p))
|
||||
(define (reader)
|
||||
(define-values (base name dir?) (split-path orig-path))
|
||||
(define unchecked-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
|
||||
(if (path? base) base (current-directory))])
|
||||
(read-src-syntax path p)))))
|
||||
(when (eof-object? unchecked-v)
|
||||
(error 'read-one "empty file; expected a module declaration in: ~a" path))
|
||||
(define sym
|
||||
(string->symbol
|
||||
(bytes->string/utf-8 (path->bytes (path-replace-suffix name #"")) #\?)))
|
||||
(define checked-v (check-module-form unchecked-v sym 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? checked-v) (compiled-expression? (syntax-e checked-v)))
|
||||
(syntax-e checked-v)
|
||||
checked-v))
|
||||
(define (closer) (close-input-port p))
|
||||
(dynamic-wind void reader closer))
|
||||
|
||||
(define-struct (exn:get-module-code exn:fail) (path))
|
||||
(define-struct (exn:get-module-code exn:fail) (path))
|
||||
|
||||
(define (get-module-code path
|
||||
#:roots [roots (current-compiled-file-roots)]
|
||||
#:submodule-path [submodule-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])
|
||||
(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)])
|
||||
(define (build-found-path base . args)
|
||||
(cond
|
||||
[(or (equal? roots '(same)) (null? roots))
|
||||
(apply build-path base args)]
|
||||
[else
|
||||
(let ([reroot-path* (lambda (base root)
|
||||
(cond
|
||||
[(eq? root 'same) base]
|
||||
[(relative-path? root) (build-path base root)]
|
||||
[else (reroot-path base root)]))])
|
||||
(or (for/or ([root (in-list (if (null? (cdr roots)) null roots))])
|
||||
(define p (apply build-path (reroot-path* base root) args))
|
||||
(and (file-exists? p) p))
|
||||
(apply build-path (reroot-path* base (car roots)) args)))]))
|
||||
(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 alt-file (not alt-path-d) (not main-path-d))]
|
||||
[get-so (lambda (file)
|
||||
(build-found-path
|
||||
base sub-path "native"
|
||||
(system-library-subpath)
|
||||
(path-add-suffix file (system-type 'so-suffix))))]
|
||||
[zo (build-found-path base sub-path (path-add-suffix file #".zo"))]
|
||||
[alt-zo (and try-alt?
|
||||
(build-found-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)])
|
||||
(define (extract-submodule m [sm-path submodule-path])
|
||||
(define (reroot-path* base root)
|
||||
(cond
|
||||
[(eq? root 'same) base]
|
||||
[(relative-path? root) (build-path base root)]
|
||||
[else (reroot-path base root)]))
|
||||
|
||||
(define (get-module-code
|
||||
path0
|
||||
#:roots [roots (current-compiled-file-roots)]
|
||||
#:submodule-path [submodule-path '()]
|
||||
#:sub-path [sub-path/kw "compiled"]
|
||||
[sub-path sub-path/kw]
|
||||
#:compile [compile/kw compile]
|
||||
[compiler compile/kw]
|
||||
#:extension-handler [ext-handler/kw #f]
|
||||
[ext-handler ext-handler/kw]
|
||||
#:choose [choose (lambda (src zo so) #f)]
|
||||
#:notify [notify void]
|
||||
#:source-reader [read-src-syntax read-syntax]
|
||||
#:rkt-try-ss? [rkt-try-ss? #t])
|
||||
(define resolved-path (resolve path0))
|
||||
(define-values (path0-rel path0-file path0-dir?) (split-path path0))
|
||||
(define-values (main-src-file alt-src-file)
|
||||
(if rkt-try-ss?
|
||||
(let* ([b (path->bytes path0-file)]
|
||||
[len (bytes-length b)])
|
||||
(cond
|
||||
[(null? sm-path) m]
|
||||
[else
|
||||
(extract-submodule
|
||||
(or (for/or ([c (in-list (append (module-compiled-submodules m #t)
|
||||
(module-compiled-submodules m #f)))])
|
||||
(and (eq? (last (module-compiled-name c)) (car sm-path))
|
||||
c))
|
||||
(raise
|
||||
(make-exn:get-module-code
|
||||
(format "get-module-code: cannot find submodule: ~e" sm-path)
|
||||
[(and (len . >= . 4) (bytes=? #".rkt" (subbytes b (- len 4))))
|
||||
;; .rkt => try .rkt then .ss
|
||||
(values path0-file
|
||||
(bytes->path (bytes-append (subbytes b 0 (- len 4))
|
||||
#".ss")))]
|
||||
[else
|
||||
;; No search path
|
||||
(values path0-file #f)]))
|
||||
(values path0-file #f)))
|
||||
(define main-src-path
|
||||
(if (eq? main-src-file path0-file)
|
||||
resolved-path
|
||||
(build-path path0-rel main-src-file)))
|
||||
(define alt-src-path
|
||||
(and alt-src-file
|
||||
(if (eq? alt-src-file path0-file)
|
||||
resolved-path
|
||||
(build-path path0-rel alt-src-file))))
|
||||
(define path0-base (if (eq? path0-rel 'relative) 'same path0-rel))
|
||||
(define (build-found-path base . args)
|
||||
(cond
|
||||
[(or (equal? roots '(same)) (null? roots))
|
||||
(apply build-path base args)]
|
||||
[else
|
||||
(or (for/or ([root (in-list (if (null? (cdr roots)) null roots))])
|
||||
(define p (apply build-path (reroot-path* base root) args))
|
||||
(and (file-exists? p) p))
|
||||
(apply build-path (reroot-path* base (car roots)) args))]))
|
||||
(define main-src-date
|
||||
(file-or-directory-modify-seconds main-src-path #f (lambda () #f)))
|
||||
(define alt-src-date
|
||||
(and alt-src-path
|
||||
(not main-src-date)
|
||||
(file-or-directory-modify-seconds alt-src-path #f (lambda () #f))))
|
||||
(define src-date (or main-src-date alt-src-date))
|
||||
(define src-file (if alt-src-date alt-src-file main-src-file))
|
||||
(define src-path (if alt-src-date alt-src-path main-src-path))
|
||||
(define try-alt? (and alt-src-file (not alt-src-date) (not main-src-date)))
|
||||
(define (get-so file)
|
||||
(build-found-path path0-base
|
||||
sub-path
|
||||
"native"
|
||||
(system-library-subpath)
|
||||
(path-add-suffix file (system-type 'so-suffix))))
|
||||
(define zo
|
||||
(build-found-path path0-base sub-path (path-add-suffix src-file #".zo")))
|
||||
(define alt-zo
|
||||
(and try-alt?
|
||||
(build-found-path path0-base
|
||||
sub-path
|
||||
(path-add-suffix alt-src-file #".zo"))))
|
||||
(define so (get-so src-file))
|
||||
(define alt-so (and try-alt? (get-so alt-src-file)))
|
||||
(define (with-dir t)
|
||||
(parameterize ([current-load-relative-directory
|
||||
(if (path? path0-base) path0-base (current-directory))])
|
||||
(t)))
|
||||
(define prefer (choose src-path zo so))
|
||||
(define (extract-submodule m [sm-path submodule-path])
|
||||
(cond
|
||||
[(null? sm-path) m]
|
||||
[else
|
||||
(extract-submodule
|
||||
(or (for/or ([c (in-list (append (module-compiled-submodules m #t)
|
||||
(module-compiled-submodules m #f)))])
|
||||
(and (eq? (last (module-compiled-name c)) (car sm-path))
|
||||
c))
|
||||
(raise
|
||||
(make-exn:get-module-code
|
||||
(format "get-module-code: cannot find submodule: ~e" sm-path)
|
||||
(current-continuation-marks)
|
||||
#f)))
|
||||
(cdr sm-path))]))
|
||||
(cond
|
||||
;; Use .zo, if it's new enough
|
||||
[(or (eq? prefer 'zo)
|
||||
(and (not prefer)
|
||||
(pair? roots)
|
||||
(or (date>=? zo src-date)
|
||||
(and try-alt?
|
||||
(date>=? alt-zo src-date)))))
|
||||
(let ([zo (if (date>=? zo src-date)
|
||||
zo
|
||||
(if (and try-alt? (date>=? alt-zo src-date))
|
||||
alt-zo
|
||||
zo))])
|
||||
(notify zo)
|
||||
(extract-submodule (read-one src-path zo #f read-syntax)))]
|
||||
;; Maybe there's an .so? Use it only if we don't prefer source
|
||||
;; and only if there's no submodule path.
|
||||
[(and (null? submodule-path)
|
||||
(or (eq? prefer 'so)
|
||||
(and (not prefer)
|
||||
(pair? roots)
|
||||
(or (date>=? so src-date)
|
||||
(and try-alt?
|
||||
(date>=? alt-so src-date))))))
|
||||
(let ([so (if (date>=? so src-date)
|
||||
so
|
||||
(if (and try-alt? (date>=? alt-so src-date))
|
||||
alt-so
|
||||
so))])
|
||||
(if ext-handler
|
||||
(begin
|
||||
(notify so)
|
||||
(ext-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) src-date)
|
||||
(notify src-path)
|
||||
(define (compile-one)
|
||||
(with-dir
|
||||
(lambda ()
|
||||
(compiler (read-one resolved-path src-path #t read-src-syntax)))))
|
||||
(if (null? submodule-path)
|
||||
;; allow any result:
|
||||
(compile-one)
|
||||
;; expect a compiled-module result:
|
||||
(extract-submodule (compile-one)))]
|
||||
;; Report a not-there error
|
||||
[else (raise (make-exn:get-module-code
|
||||
(format "get-module-code: no such file: ~e" resolved-path)
|
||||
(current-continuation-marks)
|
||||
#f)))
|
||||
(cdr sm-path))]))
|
||||
(cond
|
||||
;; Use .zo, if it's new enough
|
||||
[(or (eq? prefer 'zo)
|
||||
(and (not prefer)
|
||||
(pair? roots)
|
||||
(or (date>=? zo path-d)
|
||||
(and try-alt?
|
||||
(date>=? alt-zo path-d)))))
|
||||
(let ([zo (if (date>=? zo path-d)
|
||||
zo
|
||||
(if (and try-alt?
|
||||
(date>=? alt-zo path-d))
|
||||
alt-zo
|
||||
zo))])
|
||||
(notify zo)
|
||||
(extract-submodule (read-one path zo #f read-syntax)))]
|
||||
;; Maybe there's an .so? Use it only if we don't prefer source
|
||||
;; and only if there's no submodule path.
|
||||
[(and (null? submodule-path)
|
||||
(or (eq? prefer 'so)
|
||||
(and (not prefer)
|
||||
(pair? roots)
|
||||
(or (date>=? so path-d)
|
||||
(and try-alt?
|
||||
(date>=? alt-so path-d))))))
|
||||
(let ([so (if (date>=? so path-d)
|
||||
so
|
||||
(if (and try-alt?
|
||||
(date>=? alt-so path-d))
|
||||
alt-so
|
||||
so))])
|
||||
(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)
|
||||
(define (compile-one)
|
||||
(with-dir (lambda () (compiler (read-one orig-path path #t read-src-syntax)))))
|
||||
(if (null? submodule-path)
|
||||
;; allow any result:
|
||||
(compile-one)
|
||||
;; expect a compiled-module result:
|
||||
(extract-submodule (compile-one)))]
|
||||
;; 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))]))))
|
||||
#f))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user