diff --git a/collects/mzlib/etc.ss b/collects/mzlib/etc.ss index d266038..ecb8529 100644 --- a/collects/mzlib/etc.ss +++ b/collects/mzlib/etc.ss @@ -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 () diff --git a/collects/mzlib/runtime-path.ss b/collects/mzlib/runtime-path.ss new file mode 100644 index 0000000..2b9741e --- /dev/null +++ b/collects/mzlib/runtime-path.ss @@ -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))])) + + ) diff --git a/collects/mzlib/sandbox.ss b/collects/mzlib/sandbox.ss index b951a2a..ecf8b7e 100644 --- a/collects/mzlib/sandbox.ss +++ b/collects/mzlib/sandbox.ss @@ -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))