369.10
svn: r6003 original commit: a45251d27211d633dc1834a92bc44bddeb983316
This commit is contained in:
Matthew Flatt
parent
302308a730
commit
b9da8168b0
|
|
@ -380,24 +380,44 @@
|
|||
(not (eq? (namespace-variable-value n #t (lambda () ns-undefined))
|
||||
ns-undefined)))
|
||||
|
||||
(define (extract-module-directory stx)
|
||||
(let ([srcmod (let ([mpi (syntax-source-module stx)])
|
||||
(if (module-path-index? mpi)
|
||||
(module-path-index-resolve mpi)
|
||||
mpi))])
|
||||
(let ([str (symbol->string srcmod)])
|
||||
(and ((string-length str) . > . 1)
|
||||
(char=? #\, (string-ref str 0))
|
||||
(let ([path (bytes->path (string->bytes/latin-1 (substring str 1)))])
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(and (path? base)
|
||||
base)))))))
|
||||
|
||||
(define-syntax (this-expression-source-directory stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[dir (path->main-collects-relative
|
||||
(or (and source (file-exists? source)
|
||||
(let-values ([(base file dir?)
|
||||
(split-path source)])
|
||||
(and (path? base)
|
||||
(path->complete-path base local))))
|
||||
local))])
|
||||
(if (and (pair? dir) (eq? 'collects (car dir)))
|
||||
(with-syntax ([d dir])
|
||||
#'(main-collects-relative->path 'd))
|
||||
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
||||
#'(bytes->path d))))]))
|
||||
(let ([source-path
|
||||
(let* ([source (syntax-source stx)]
|
||||
[source (and (path? source) source)]
|
||||
[local (or (current-load-relative-directory) (current-directory))]
|
||||
[dir (path->main-collects-relative
|
||||
(or (and source (file-exists? source)
|
||||
(let-values ([(base file dir?)
|
||||
(split-path source)])
|
||||
(and (path? base)
|
||||
(path->complete-path base local))))
|
||||
local))])
|
||||
(if (and (pair? dir) (eq? 'collects (car dir)))
|
||||
(with-syntax ([d dir])
|
||||
(syntax/loc stx (main-collects-relative->path 'd)))
|
||||
(with-syntax ([d (if (bytes? dir) dir (path->bytes dir))])
|
||||
(syntax/loc stx (bytes->path d)))))])
|
||||
(let ([mpi (syntax-source-module stx)])
|
||||
(if mpi
|
||||
(quasisyntax/loc stx
|
||||
(or (extract-module-directory (quote-syntax #,stx))
|
||||
#,source-path))
|
||||
source-path)))]))
|
||||
|
||||
(define-syntax (this-expression-file-name stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
137
collects/mzlib/runtime-path.ss
Normal file
137
collects/mzlib/runtime-path.ss
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
|
||||
(module runtime-path mzscheme
|
||||
(require (lib "etc.ss")
|
||||
(lib "modcollapse.ss" "syntax")
|
||||
(lib "dirs.ss" "setup")
|
||||
(only "private/runtime-path-table.ss" table))
|
||||
|
||||
(provide define-runtime-path
|
||||
define-runtime-paths
|
||||
define-runtime-path-list
|
||||
runtime-paths)
|
||||
|
||||
(define-for-syntax ext-file-table (make-hash-table))
|
||||
|
||||
(define (lookup-in-table tag-stx p)
|
||||
;; This function is designed to cooperate with a table embedded
|
||||
;; in an executable by create-embedding-executable.
|
||||
(let ([mpi (syntax-source-module tag-stx)])
|
||||
(let ([p (hash-table-get
|
||||
table
|
||||
(cons (cond
|
||||
[(module-path-index? mpi)
|
||||
(module-path-index-resolve mpi)]
|
||||
[(symbol? mpi) mpi]
|
||||
[else #f])
|
||||
(if (path? p)
|
||||
(path->bytes p)
|
||||
p))
|
||||
#f)])
|
||||
(and p
|
||||
(car p)
|
||||
(let* ([p (car p)]
|
||||
[p (if (bytes? p)
|
||||
(bytes->path p)
|
||||
p)])
|
||||
(if (absolute-path? p)
|
||||
p
|
||||
(parameterize ([current-directory (find-system-path 'orig-dir)])
|
||||
(or (find-executable-path (find-system-path 'exec-file) p #t)
|
||||
(build-path (current-directory) p)))))))))
|
||||
|
||||
(define (resolve-paths tag-stx get-base paths)
|
||||
(let ([base #f])
|
||||
(map (lambda (p)
|
||||
(or
|
||||
;; Check table potentially substituted by
|
||||
;; mzc --exe:
|
||||
(and table
|
||||
(lookup-in-table tag-stx p))
|
||||
;; Normal resolution
|
||||
(cond
|
||||
[(and (or (string? p) (path? p))
|
||||
(not (complete-path? p)))
|
||||
(unless base
|
||||
(set! base (get-base)))
|
||||
(path->complete-path p base)]
|
||||
[(string? p) (string->path p)]
|
||||
[(path? p) p]
|
||||
[(and (list? p)
|
||||
(= 2 (length p))
|
||||
(eq? 'so (car p))
|
||||
(string? (cadr p)))
|
||||
(let ([f (path-replace-suffix (cadr p) (system-type 'so-suffix))])
|
||||
(or (ormap (lambda (p)
|
||||
(let ([p (build-path p f)])
|
||||
(and (file-exists? p)
|
||||
p)))
|
||||
(get-lib-search-dirs))
|
||||
(cadr p)))]
|
||||
[else (error 'runtime-path "unknown form: ~e" p)])))
|
||||
paths)))
|
||||
|
||||
(define-for-syntax (register-ext-files tag-stx paths)
|
||||
(let ([mpi (syntax-source-module tag-stx)])
|
||||
(let ([modname (cond
|
||||
[(module-path-index? mpi) (module-path-index-resolve mpi)]
|
||||
[(symbol? mpi) mpi]
|
||||
[else (error 'register-ext-files
|
||||
"cannot determine source")])])
|
||||
(let ([files (hash-table-get ext-file-table modname null)])
|
||||
(hash-table-put! ext-file-table modname (append paths files))))))
|
||||
|
||||
(define-syntax (-define-runtime-path stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx (id ...) expr to-list to-values)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(unless (memq (syntax-local-context) '(module module-begin top-level))
|
||||
(raise-syntax-error #f "allowed only at the top level" #'orig-stx))
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
#'orig-stx
|
||||
id)))
|
||||
ids)
|
||||
(let ([tag (datum->syntax-object #'orig-stx 'tag #'orig-stx)])
|
||||
#`(begin
|
||||
(define-values (id ...)
|
||||
(let-values ([(id ...) expr])
|
||||
(let ([get-dir (lambda ()
|
||||
#,(datum->syntax-object
|
||||
tag
|
||||
`(,#'this-expression-source-directory)
|
||||
tag))])
|
||||
(apply to-values (resolve-paths (quote-syntax #,tag)
|
||||
get-dir
|
||||
(to-list id ...))))))
|
||||
(begin-for-syntax
|
||||
(register-ext-files
|
||||
(quote-syntax #,tag)
|
||||
(let-values ([(id ...) expr])
|
||||
(to-list id ...)))))))]))
|
||||
|
||||
(define-syntax (define-runtime-path stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr) #`(-define-runtime-path #,stx (id) expr list values)]))
|
||||
|
||||
(define-syntax (define-runtime-paths stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values)]))
|
||||
|
||||
(define-syntax (define-runtime-path-list stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)]))
|
||||
|
||||
(define-syntax (runtime-paths stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mp)
|
||||
#`(quote
|
||||
#,(hash-table-get
|
||||
ext-file-table
|
||||
(module-path-index-resolve (module-path-index-join
|
||||
(syntax-object->datum #'mp)
|
||||
(syntax-source-module stx)))
|
||||
null))]))
|
||||
|
||||
)
|
||||
|
|
@ -362,13 +362,6 @@
|
|||
(define (get-uncovered-expressions eval . args)
|
||||
(apply (eval get-uncovered-expressions) args))
|
||||
|
||||
(define-syntax parameterize*
|
||||
(syntax-rules ()
|
||||
[(parameterize* ([p1 v1] [p v] ...) body ...)
|
||||
(parameterize ([p1 v1]) (parameterize* ([p v] ...) body ...))]
|
||||
[(parameterize* () body ...)
|
||||
(begin body ...)]))
|
||||
|
||||
(define (make-evaluator* init-hook require-perms program-or-maker)
|
||||
(define cust (make-custodian))
|
||||
(define coverage? (sandbox-coverage-enabled))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user