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

Exported two more functions from syntax/modcode.

Browse Source 
The get-module-path function was described in the previous commit.
The get-metadata-path function constructs the paths used to saved .zo files
and so forth; e.g. PATH/compiled/NAME_rkt.zo.
This commit is contained in:
Carl Eastlund 2013-06-09 22:19:44 -04:00
parent d7ebc497ba
commit db1ba7af5e
1 changed files with 59 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
collects/syntax/modcode.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require racket/contract/base (require racket/contract/base
racket/list racket/list
racket/path
"modread.rkt") "modread.rkt")
(provide moddep-current-open-input-file (provide moddep-current-open-input-file
@ -10,24 +11,35 @@
make-exn:get-module-code) make-exn:get-module-code)
(provide/contract (provide/contract
[get-module-code (->* (path?) [get-module-code
(#:roots (->* (path?)
(listof (or/c path? 'same)) (#:roots (listof (or/c path? 'same))
#:submodule-path #:submodule-path (listof symbol?)
(listof symbol?) #:sub-path (and/c path-string? relative-path?)
#:sub-path (and/c path-string? relative-path?)
(and/c path-string? relative-path?) #:compile (-> any/c any)
(and/c path-string? relative-path?) (-> any/c any)
#:compile (-> any/c any) #:extension-handler (or/c false/c (path? boolean? . -> . any))
(-> any/c any) (or/c false/c (path? boolean? . -> . any))
#:extension-handler (or/c false/c (path? boolean? . -> . any)) #:choose (path? path? path? . -> . (or/c 'src 'zo 'so #f))
(or/c false/c (path? boolean? . -> . any)) #:notify (any/c . -> . any)
#:choose #:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?))
(path? path? path? . -> . (or/c (symbols 'src 'zo 'so) false/c)) #:rkt-try-ss? boolean?)
#:notify (any/c . -> . any) any)]
#:source-reader (any/c input-port? . -> . (or/c syntax? eof-object?)) [get-module-path
#:rkt-try-ss? boolean?) (->* (path?)
any)]) (#:roots (listof (or/c path? 'same))
#:submodule? boolean?
#:sub-path (and/c path-string? relative-path?)
(and/c path-string? relative-path?)
#:choose (path? path? path? . -> . (or/c 'src 'zo 'so #f))
#:rkt-try-ss? boolean?)
(values path? (or/c 'src 'zo 'so)))]
[get-metadata-path
(->* (path?)
(#:roots (listof (or/c path? 'same)))
#:rest (listof (or/c path-string? 'same))
path?)])
(define moddep-current-open-input-file (define moddep-current-open-input-file
(make-parameter open-input-file)) (make-parameter open-input-file))
@ -82,6 +94,18 @@
[(relative-path? root) (build-path base root)] [(relative-path? root) (build-path base root)]
[else (reroot-path base root)])) [else (reroot-path base root)]))
(define (get-metadata-path
#:roots [roots (current-compiled-file-roots)]
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 (get-module-path (define (get-module-path
path0 path0
#:roots [roots (current-compiled-file-roots)] #:roots [roots (current-compiled-file-roots)]
@ -116,15 +140,6 @@
resolved-path resolved-path
(build-path path0-rel alt-src-file)))) (build-path path0-rel alt-src-file))))
(define path0-base (if (eq? path0-rel 'relative) 'same path0-rel)) (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 (define main-src-date
(file-or-directory-modify-seconds main-src-path #f (lambda () #f))) (file-or-directory-modify-seconds main-src-path #f (lambda () #f)))
(define alt-src-date (define alt-src-date
@ -136,18 +151,23 @@
(define src-path (if alt-src-date alt-src-path main-src-path)) (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 try-alt? (and alt-src-file (not alt-src-date) (not main-src-date)))
(define (get-so file) (define (get-so file)
(build-found-path path0-base (get-metadata-path #:roots roots
sub-path path0-base
"native" sub-path
(system-library-subpath) "native"
(path-add-suffix file (system-type 'so-suffix)))) (system-library-subpath)
(path-add-suffix file (system-type 'so-suffix))))
(define zo (define zo
(build-found-path path0-base sub-path (path-add-suffix src-file #".zo"))) (get-metadata-path #:roots roots
path0-base
sub-path
(path-add-suffix src-file #".zo")))
(define alt-zo (define alt-zo
(and try-alt? (and try-alt?
(build-found-path path0-base (get-metadata-path #:roots roots
sub-path path0-base
(path-add-suffix alt-src-file #".zo")))) sub-path
(path-add-suffix alt-src-file #".zo"))))
(define so (get-so src-file)) (define so (get-so src-file))
(define alt-so (and try-alt? (get-so alt-src-file))) (define alt-so (and try-alt? (get-so alt-src-file)))
(define prefer (choose src-path zo so)) (define prefer (choose src-path zo so))
@ -164,7 +184,7 @@
(if (and try-alt? (date>=? alt-zo src-date)) (if (and try-alt? (date>=? alt-zo src-date))
alt-zo alt-zo
zo))]) zo))])
(values zo 'zo))] (values (simple-form-path zo) 'zo))]
;; Maybe there's an .so? Use it only if we don't prefer source ;; Maybe there's an .so? Use it only if we don't prefer source
;; and only if there's no submodule path. ;; and only if there's no submodule path.
[(and (not submodule?) [(and (not submodule?)
@ -179,10 +199,10 @@
(if (and try-alt? (date>=? alt-so src-date)) (if (and try-alt? (date>=? alt-so src-date))
alt-so alt-so
so))]) so))])
(values so 'so))] (values (simple-form-path so) 'so))]
;; Use source if it exists ;; Use source if it exists
[(or (eq? prefer 'src) src-date) [(or (eq? prefer 'src) src-date)
(values src-path 'src)] (values (simple-form-path src-path) 'src)]
;; Report a not-there error ;; Report a not-there error
[else (raise (make-exn:get-module-code [else (raise (make-exn:get-module-code
(format "get-module-code: no such file: ~e" resolved-path) (format "get-module-code: no such file: ~e" resolved-path)