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

misc changes to avoid absolute paths in bytecode files

Browse Source 
In many cases, `path->collects-relative' is used instead of
`path->main-collects-relative' to generalize existing support
for collection-relative paths.
This commit is contained in:
Matthew Flatt 2013-07-08 12:22:10 -06:00
parent f34a689bd7
commit f87981f960
19 changed files with 177 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/gui-pkgs/gui-lib/mrlib/include-bitmap.rkt
View File

@ -31,7 +31,7 @@
(with-syntax ([content content]
[c-file (path->main-collects-relative c-file)])
(syntax/loc stx
(get-or-load-bitmap content 'c-file type))))]))
(get-or-load-bitmap content 'path-spec type))))]))
(define-syntax (include-bitmap/relative-to stx)
(syntax-case stx ()

5
pkgs/gui-pkgs/gui-lib/rackunit/private/gui/drracket-ui.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base
(require mzlib/etc
"drracket-link.rkt")
(require "drracket-link.rkt")
;; Procedures which *may* be overridden by DrRacket to do useful things.
;; Or they may not be.
@ -49,7 +48,7 @@
(not (regexp-match?
(regexp-quote
(path->string
(this-expression-source-directory)))
(collection-path "rackunit" "private" "gui")))
(path->string src)))))))
srclocs)))

7
pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl
View File

@ -657,10 +657,9 @@ follows from the @racket[define-runtime-path] syntactic form:
]
In the latter two cases, the path is normally preserved in
(platform-specific) byte form. If it is is within the result of
@racket[find-collects-dir], however, it the path is recorded relative
to @racket[(find-collects-dir)], and it is reconstructed using
@racket[(find-collects-dir)] at run time.
(platform-specific) byte form, but if the enclosing path corresponds to a
result of @racket[collection-file-path], then the path is record as
relative to the corresponding module path.
Examples:

7
pkgs/racket-pkgs/racket-doc/syntax/scribblings/quote.scrbl
View File

@ -8,10 +8,13 @@
provides support for quoting syntax so that it's source locations
are preserved in marshaled bytecode form.}
@defform[(quote-syntax/keep-srcloc datum)]{
@defform*[[(quote-syntax/keep-srcloc datum)
(quote-syntax/keep-srcloc #:source source-expr datum)]]{
Like @racket[(quote-syntax datum)], but the source locations of
@racket[datum] are preserved.
@racket[datum] are preserved. If a @racket[source-expr] is provided,
then it is used in place of a @racket[syntax-source] value for
each syntax object within @racket[datum].
Unlike a @racket[quote-syntax] form, the results of evaluating the
expression multiple times are not necessarily @racket[eq?].}

6
pkgs/scribble-pkgs/scribble-lib/scribble/base-render.rkt
View File

@ -6,7 +6,7 @@
mzlib/serialize
scheme/file
scheme/path
setup/main-collects
setup/collects
setup/path-relativize
file/convertible
net/url-structs
@ -142,7 +142,7 @@
(for/list ([(k v) (in-hash ht)])
(cons v (if (or (bytes? k) (url? k))
k
(main-collects-relative->path k))))
(collects-relative->path k))))
<
#:key car))))
@ -751,7 +751,7 @@
(style-properties (part-style d)))])
(when extras
(for ([fn (in-list (auto-extra-files-paths extras))])
(install-file (main-collects-relative->path fn)
(install-file (collects-relative->path fn)
#:private-name? #f)))))))
(define/public (render ds fns ri)

12
pkgs/scribble-pkgs/scribble-lib/scribble/html-render.rkt
View File

@ -12,7 +12,7 @@
file/convertible
mzlib/runtime-path
setup/main-doc
setup/main-collects
setup/collects
setup/dirs
net/url
net/uri-codec
@ -259,7 +259,7 @@
(define (path->relative p)
(let ([p (path->main-doc-relative p)])
(if (path? p)
(let ([p (path->main-collects-relative p)])
(let ([p (path->collects-relative p)])
(if (path? p)
(path->root-relative p)
(intern-taglet p)))
@ -274,7 +274,7 @@
p)])
(if (path? p)
p
(main-collects-relative->path p)))))
(collects-relative->path p)))))
;; ----------------------------------------
@ -711,14 +711,14 @@
(let ([v (html-defaults-prefix-path defaults)])
(if (bytes? v)
v
(main-collects-relative->path v))))
(collects-relative->path v))))
scribble-prefix-html)]
[style-file (or style-file
(and defaults
(let ([v (html-defaults-style-path defaults)])
(if (bytes? v)
v
(main-collects-relative->path v))))
(collects-relative->path v))))
scribble-style-css)]
[script-file (or script-file scribble-js)]
[title (cond [(part-title-content d)
@ -1097,7 +1097,7 @@
[width ,(number->string w)]
[height ,(number->string h)])))))]
[(image-element? e)
(let* ([src (main-collects-relative->path (image-element-path e))]
(let* ([src (collects-relative->path (image-element-path e))]
[suffixes (image-element-suffixes e)]
[scale (image-element-scale e)]
[to-num

4
pkgs/scribble-pkgs/scribble-lib/scribble/jfp.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require setup/main-collects
(require setup/collects
scribble/core
(except-in scribble/base author)
scribble/decode
@ -13,7 +13,7 @@
(define jfp-extras
(let ([abs (lambda (s)
(path->main-collects-relative
(path->collects-relative
(collection-file-path s "scribble" "jfp")))])
(list
(make-css-addition (abs "jfp.css"))

4
pkgs/scribble-pkgs/scribble-lib/scribble/jfp/lang.rkt
View File

@ -2,7 +2,7 @@
(require scribble/doclang
(except-in scribble/base author)
scribble/jfp
setup/main-collects
setup/collects
"../private/defaults.rkt"
net/ftp
racket/file
@ -26,7 +26,7 @@
(define cls-file
(let ([p (scribble-file "jfp/jfp1.cls")])
(if (file-exists? (main-collects-relative->path p))
(if (file-exists? (collects-relative->path p))
p
(downloaded-file "jfp1.cls"))))

8
pkgs/scribble-pkgs/scribble-lib/scribble/latex-render.rkt
View File

@ -7,7 +7,7 @@
racket/port
racket/string
racket/list
setup/main-collects
setup/collects
file/convertible)
(provide render-mixin
make-render-part-mixin)
@ -76,14 +76,14 @@
(let ([v (latex-defaults-prefix defaults)])
(cond
[(bytes? v) v]
[else (main-collects-relative->path v)])))
[else (collects-relative->path v)])))
scribble-prefix-tex)]
[style-file (or style-file
(and defaults
(let ([v (latex-defaults-style defaults)])
(cond
[(bytes? v) v]
[else (main-collects-relative->path v)])))
[else (collects-relative->path v)])))
scribble-style-tex)]
[all-style-files (cons scribble-tex
(append (extract-part-style-files
@ -330,7 +330,7 @@
(check-render)
(let ([fn (install-file
(select-suffix
(main-collects-relative->path
(collects-relative->path
(image-element-path e))
(image-element-suffixes e)
'(".pdf" ".ps" ".png")))])

6
pkgs/scribble-pkgs/scribble-lib/scribble/lncs/lang.rkt
View File

@ -6,7 +6,7 @@
(prefix-in s/b: scribble/base)
scribble/decode
"../private/defaults.rkt"
setup/main-collects
setup/collects
scribble/html-properties
scribble/latex-properties
scribble/latex-prefix
@ -38,7 +38,7 @@
(define cls-file
(let ([p (scribble-file "lncs/llncs.cls")])
(if (file-exists? (main-collects-relative->path p))
(if (file-exists? (collects-relative->path p))
p
(downloaded-file "llncs.cls"))))
@ -52,7 +52,7 @@
(define lncs-extras
(let ([abs (lambda (s)
(path->main-collects-relative
(path->collects-relative
(collection-file-path s "scribble" "lncs")))])
(list
(make-css-addition (abs "lncs.css"))

4
pkgs/scribble-pkgs/scribble-lib/scribble/private/defaults.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scribble/core
scribble/latex-properties
setup/main-collects)
setup/collects)
(provide scribble-file
downloaded-file
@ -13,7 +13,7 @@
(cons new properties)))
(define (scribble-file s)
(path->main-collects-relative (collection-file-path s "scribble")))
(path->collects-relative (collection-file-path s "scribble")))
(define (downloaded-file s)
(build-path (find-system-path 'addon-dir) s))

4
pkgs/scribble-pkgs/scribble-lib/scribble/private/manual-sprop.rkt
View File

@ -2,12 +2,12 @@
(require "../html-properties.rkt"
"../latex-properties.rkt"
"on-demand.rkt"
setup/main-collects)
setup/collects)
(provide scheme-properties)
(define-on-demand scheme-properties
(let ([abs (lambda (s)
(path->main-collects-relative (collection-file-path s "scribble")))])
(path->collects-relative (collection-file-path s "scribble")))])
(list (make-css-addition (abs "racket.css"))
(make-tex-addition (abs "racket.tex")))))

4
pkgs/scribble-pkgs/scribble-lib/scribble/sigplan.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base
(require setup/main-collects
(require setup/collects
racket/contract/base
scribble/core
scribble/base
@ -52,7 +52,7 @@
(define sigplan-extras
(let ([abs (lambda (s)
(path->main-collects-relative
(path->collects-relative
(collection-file-path s "scribble" "sigplan")))])
(list
(make-css-addition (abs "sigplan.css"))

2
pkgs/scribble-pkgs/scribble-lib/scribble/srcdoc.rkt
View File

@ -77,7 +77,7 @@
(define (get-docs)
(list (quote-syntax (req ... ...))
(quote-syntax (expr ...))
(quote-syntax/keep-srcloc doc-body))))))
(quote-syntax/keep-srcloc #:source 'doc doc-body))))))
;; normal mode: return an identifier that holds the document:
(with-syntax ([((id d) ...) #'doc-body])
#'(begin-for-syntax

4
pkgs/scribble-pkgs/scribble-lib/scribble/tag.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require racket/contract/base
syntax/modcollapse
setup/main-collects
setup/collects
scribble/core
;; Needed to normalize planet version numbers:
(only-in planet/resolver get-planet-module-path/pkg)
@ -66,7 +66,7 @@
(module-path-index-resolve mod))])
(if (path? rp)
(intern-taglet
(path->main-collects-relative rp))
(path->collects-relative rp))
rp))
(let ([p (if (and (pair? p)
(eq? (car p) 'planet))

5
racket/lib/collects/racket/HISTORY.txt
View File

@ -3,6 +3,11 @@ Added call-with-default-reading-parameterization
racket/file: added call-with-atomic-output-file
pkg/path: added, re-exported by pkg/lib
setup/path-to-relative: added <pkg> results
racket/runtime-path: special handling for paths that
correspond to collection-file-path results, instead of
paths that are relative to the main "collects"
scribble: same change as for racket/runtime-path related
to "collects"-relative paths
Version 5.3.900.4
Added filesystem-change-evt, filesystem-change-evt?, and

78
racket/lib/collects/racket/private/this-expression-source-directory.rkt
View File

@ -1,9 +1,14 @@
#lang racket/base
(require (for-syntax racket/base
setup/collects
setup/main-collects)
setup/collects
setup/main-collects)
(provide this-expression-source-directory)
(define-syntax (this-expression-source-directory stx)
(provide this-expression-source-directory
this-expression-source-file)
(define-for-syntax (this-expression-source stx dir?)
(syntax-case stx ()
[(_ sub)
(let ([stx (syntax sub)])
@ -11,31 +16,52 @@
(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))])
[x-dir (or (and source
(file-exists? source)
(if dir?
(let-values ([(base file dir?)
(split-path source)])
(and (path? base)
(path->complete-path base local)))
source))
(if dir?
local
(build-path local
(if source
(let-values ([(base file dir?)
(split-path source)])
file)
"unknown"))))]
[dir (if dir?
(path->main-collects-relative x-dir)
(path->collects-relative x-dir))])
(if (and (pair? dir) (eq? 'collects (car dir)))
(with-syntax ([d dir])
(syntax/loc stx (main-collects-relative->path 'd)))
(with-syntax ([d dir]
[relative->path (if dir?
#'main-collects-relative->path
#'collects-relative->path)])
(syntax/loc stx (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 #,(datum->syntax
stx
'context
stx
stx)))
#,source-path))
(with-syntax ([extract (if dir?
#'extract-module-directory
#'extract-module-file)])
(quasisyntax/loc stx
(or (extract
(quote-syntax #,(datum->syntax stx 'context stx stx)))
#,source-path)))
source-path))))]
[(_) #`(this-expression-source-directory #,stx)]))
[(_) (this-expression-source #`(x #,stx) dir?)]))
(define (extract-module-directory stx)
(define-syntax (this-expression-source-directory stx)
(this-expression-source stx #t))
(define-syntax (this-expression-source-file stx)
(this-expression-source stx #f))
(define (extract-module stx dir?)
(let ([srcmod (let ([mpi (syntax-source-module stx)])
(if (module-path-index? mpi)
(module-path-index-resolve mpi)
@ -43,7 +69,13 @@
(let* ([name (resolved-module-path-name srcmod)]
[name (if (pair? name) (car name) name)])
(and (path? name)
(let-values ([(base name dir?) (split-path name)])
(and (path? base)
base))))))
(if dir?
(let-values ([(base name dir?) (split-path name)])
(and (path? base)
base))
name)))))
(define (extract-module-directory stx)
(extract-module stx #t))
(define (extract-module-file stx)
(extract-module stx #f))

27
racket/lib/collects/racket/runtime-path.rkt
View File

@ -139,6 +139,10 @@
(module-path-index-join p base))))]
[else (error 'runtime-path "unknown form: ~.s" p)])))
paths)))
(define (path-of p)
(let-values ([(base name dir?) (split-path p)])
base))
(define-for-syntax (register-ext-files var-ref paths)
(let ([modname (variable-reference->resolved-module-path var-ref)])
@ -147,7 +151,7 @@
(define-syntax (-define-runtime-path stx)
(syntax-case stx ()
[(_ orig-stx (id ...) expr to-list to-values)
[(_ orig-stx (id ...) expr to-list to-values need-dir?)
(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))
@ -167,11 +171,14 @@
#`(begin
(define-values (id ...)
(let-values ([(id ...) expr])
(let ([get-dir (lambda ()
#,(datum->syntax
#'orig-stx
`(,#'this-expression-source-directory)
#'orig-stx))])
(let ([get-dir #,(if (syntax-e #'need-dir?)
#`(lambda ()
(path-of
#,(datum->syntax
#'orig-stx
`(,#'this-expression-source-file)
#'orig-stx)))
#'void)])
(apply to-values (resolve-paths (#%variable-reference)
get-dir
(to-list id ...))))))
@ -183,19 +190,19 @@
(define-syntax (define-runtime-path stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr list values)]))
[(_ id expr) #`(-define-runtime-path #,stx (id) expr list values #t)]))
(define-syntax (define-runtime-paths stx)
(syntax-case stx ()
[(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values)]))
[(_ (id ...) expr) #`(-define-runtime-path #,stx (id ...) expr list values #t)]))
(define-syntax (define-runtime-path-list stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list)]))
[(_ id expr) #`(-define-runtime-path #,stx (id) expr values list #t)]))
(define-syntax (define-runtime-module-path-index stx)
(syntax-case stx ()
[(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values)]))
[(_ id expr) #`(-define-runtime-path #,stx (id) `(module ,expr ,(#%variable-reference)) list values #f)]))
(define-syntax (runtime-paths stx)
(syntax-case stx ()

115
racket/lib/collects/syntax/quote.rkt
View File

@ -21,60 +21,65 @@
(loop i)))]
[else #`(quote #,n)]))]
[else n]))
(define (convert e src-stx)
(let loop ([e e])
(cond
[(pair? e)
(define a (car e))
(define new-a (loop a))
(define b (cdr e))
(define new-b (loop b))
(if (and (eq? a new-a) (eq? b new-b))
e
#`(cons #,(wrap a new-a) #,(wrap b new-b)))]
[(vector? e)
(define new-vec (for/list ([i (in-vector e)])
(loop i)))
(if (for/and ([i (in-vector e)]
[n (in-list new-vec)])
(eq? i n))
e
#`(vector . #,(for/list ([i (in-vector e)]
[n (in-list new-vec)])
(wrap i n))))]
[(prefab-struct-key e)
(define l (cdr (vector->list (struct->vector e))))
(define new-l (for/list ([i (in-list l)])
(loop i)))
(if (equal? l new-l)
e
#`(make-prefab-struct '#,(prefab-struct-key e)
. #,(for/list ([i (in-list l)]
[n (in-list new-l)])
(wrap i n))))]
[(box? e)
(define a (unbox e))
(define new-a (loop a))
(if (eq? a new-a)
e
#`(box #,(wrap a new-a)))]
[(syntax? e)
(define v (syntax-e e))
(define new-v (loop v))
(if (and (eq? v new-v)
(not (syntax-position e))
(not (syntax-property e 'paren-shape)))
e
(let ([s #`(datum->syntax (quote-syntax #,(datum->syntax e 'ctx))
#,(wrap v new-v)
`#(#,(if src-stx
#`(unquote #,src-stx)
(syntax-source e))
#,(syntax-line e)
#,(syntax-column e)
#,(syntax-position e)
#,(syntax-span e)))])
(if (syntax-property e 'paren-shape)
#`(syntax-property #,s 'paren-shape '#,(syntax-property e 'paren-shape))
s)))]
[else e])))
(syntax-case stx ()
[(_ #:source src-expr e)
(wrap #'e (convert #'e #'src-expr))]
[(_ e)
(wrap #'e
(let loop ([e #'e])
(cond
[(pair? e)
(define a (car e))
(define new-a (loop a))
(define b (cdr e))
(define new-b (loop b))
(if (and (eq? a new-a) (eq? b new-b))
e
#`(cons #,(wrap a new-a) #,(wrap b new-b)))]
[(vector? e)
(define new-vec (for/list ([i (in-vector e)])
(loop i)))
(if (for/and ([i (in-vector e)]
[n (in-list new-vec)])
(eq? i n))
e
#`(vector . #,(for/list ([i (in-vector e)]
[n (in-list new-vec)])
(wrap i n))))]
[(prefab-struct-key e)
(define l (cdr (vector->list (struct->vector e))))
(define new-l (for/list ([i (in-list l)])
(loop i)))
(if (equal? l new-l)
e
#`(make-prefab-struct '#,(prefab-struct-key e)
. #,(for/list ([i (in-list l)]
[n (in-list new-l)])
(wrap i n))))]
[(box? e)
(define a (unbox e))
(define new-a (loop a))
(if (eq? a new-a)
e
#`(box #,(wrap a new-a)))]
[(syntax? e)
(define v (syntax-e e))
(define new-v (loop v))
(if (and (eq? v new-v)
(not (syntax-position e))
(not (syntax-property e 'paren-shape)))
e
(let ([s #`(datum->syntax (quote-syntax #,(datum->syntax e 'ctx))
#,(wrap v new-v)
(quote #(#,(syntax-source e)
#,(syntax-line e)
#,(syntax-column e)
#,(syntax-position e)
#,(syntax-span e))))])
(if (syntax-property e 'paren-shape)
#`(syntax-property #,s 'paren-shape '#,(syntax-property e 'paren-shape))
s)))]
[else e])))]))
(wrap #'e (convert #'e #f))]))