diff --git a/collects/compiler/cm.rkt b/collects/compiler/cm.rkt index 36364fa35b..d11c5c73ce 100644 --- a/collects/compiler/cm.rkt +++ b/collects/compiler/cm.rkt @@ -3,6 +3,7 @@ syntax/modresolve syntax/modread setup/main-collects + setup/dirs unstable/file racket/file racket/list @@ -374,10 +375,22 @@ (exn-message ex)) (raise ex))]) (parameterize ([current-write-relative-directory - (let-values ([(base name dir?) (split-path path)]) - (if (eq? base 'relative) - (current-directory) - (path->complete-path base (current-directory))))]) + (let* ([dir + (let-values ([(base name dir?) (split-path path)]) + (if (eq? base 'relative) + (current-directory) + (path->complete-path base (current-directory))))] + [collects-dir (find-collects-dir)] + [e-dir (explode-path dir)] + [e-collects-dir (explode-path collects-dir)]) + (if (and ((length e-dir) . > . (length e-collects-dir)) + (for/and ([a (in-list e-dir)] + [b (in-list e-collects-dir)]) + (equal? a b))) + ;; `dir' extends `collects-dir': + (cons dir collects-dir) + ;; `dir' doesn't extend `collects-dir': + dir))]) (let ([b (open-output-bytes)]) ;; Write bytecode into string (write code b) diff --git a/collects/scribblings/reference/write.scrbl b/collects/scribblings/reference/write.scrbl index 0798074864..32b1db7fe9 100644 --- a/collects/scribblings/reference/write.scrbl +++ b/collects/scribblings/reference/write.scrbl @@ -251,16 +251,27 @@ object within @litchar{#} (after the @defparam*[current-write-relative-directory path - (or/c (and/c path-string? complete-path?) #f) - (or/c (and/c path? complete-path?) #f)]{ + (or/c (and/c path-string? complete-path?) + (cons/c (and/c path-string? complete-path?) + (and/c path-string? complete-path?)) + #f) + (or/c (and/c path? complete-path?) + (cons/c (and/c path? complete-path?) + (and/c path? complete-path?)) + #f)]{ A parameter that is used when writing compiled code (see @secref["print-compiled"]) that contains pathname literals, including source-location pathnames for procedure -names. When not @racket[#f], paths that syntactically extend the -parameter's value are converted to relative paths; when the resulting +names. When the parameter's value is a @racket[_path], paths that syntactically extend @racket[_path] +are converted to relative paths; when the resulting compiled code is read, relative paths are converted back to complete paths using the @racket[current-load-relative-directory] parameter (if -it is not @racket[#f]; otherwise, the path is left relative).} +it is not @racket[#f]; otherwise, the path is left relative). +When the parameter's value is @racket[(cons _rel-to-path _base-path)], then +paths that syntactically extend @racket[_base-path] are converted as relative to @racket[_rel-to-path]; +the @racket[_rel-to-path] must extend @racket[_base-path], in which case @racket['up] +path elements (in the sense of @racket[build-path]) may be used to make a path relative +to @racket[_rel-to-path].} diff --git a/collects/tests/racket/print.rktl b/collects/tests/racket/print.rktl index 436137f2c9..fd756b337d 100644 --- a/collects/tests/racket/print.rktl +++ b/collects/tests/racket/print.rktl @@ -211,4 +211,40 @@ (test "Σ" in-string write 'Σ) (test "a\\\xA0b" in-string write (string->symbol "a\xA0b")))) +;; ---------------------------------------- + +(let ([p (build-path (current-directory) "something")]) + ;; path value in compiled code => path appears in .zo format: + (let ([o (open-output-string)]) + (write (compile p) o) + (test #t regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o))) + ;; `current-write-relative-directory' set => path not in .zo format: + (let ([o (open-output-string)]) + (parameterize ([current-write-relative-directory (current-directory)]) + (write (compile p) o) + (test #f regexp-match? (regexp-quote (path->bytes (current-directory))) (get-output-string o)))) + ;; try all possible supers that have at least two path elements: + (let loop ([super (current-directory)]) + (let ([super (let-values ([(base name dir?) (split-path super)]) + (if (eq? base 'root) + #f + base))]) + (when (and super + ((length (explode-path super)) . >= . 2)) + ;; `current-write-relative-directory' set => super can be in .zo format: + (let ([o (open-output-string)]) + (parameterize ([current-write-relative-directory (current-directory)]) + (write (compile (build-path super "other")) o) + (test #t regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))) + (let ([o (open-output-string)]) + (parameterize ([current-write-relative-directory (cons (current-directory) + super)]) + (write (compile (build-path super "other")) o) + (test #f regexp-match? (regexp-quote (path->bytes super)) (get-output-string o)))) + (loop super))))) + + + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/zo-path.rkt b/collects/tests/zo-path.rkt new file mode 100644 index 0000000000..003c21ffc6 --- /dev/null +++ b/collects/tests/zo-path.rkt @@ -0,0 +1,33 @@ +#lang racket +(require setup/dirs) + +;; Paths from the biuld location shouldn't show up in bytecode files +;; or documentation. Check ".zo", ".dep", and ".html" files in the +;; build on the assumption that the first three elements of the +;; build path are unique enough that they shouldn't appear anywhere. + +(define rx:dir + (byte-regexp + (regexp-quote + (path->bytes + (apply build-path + (take (explode-path (find-collects-dir)) + 3)))))) + +(define (check-content rx:name) + (lambda (name kind v) + (when (regexp-match? rx:name name) + (call-with-input-file* name + (lambda (in) + (when (regexp-match? rx:dir in) + (eprintf "Found ~s in ~s\n" rx:dir name))))))) + + +(fold-files (check-content #rx"[.](?:zo|dep)$") + (void) + (find-collects-dir)) + +;; Check rendered docs, too: +(fold-files (check-content #rx"[.](?:html)$") + (void) + (find-doc-dir)) diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 196e20f56c..9d40486020 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,7 @@ +Version 5.2.1.5 +Changed current-write-relative-directory to support a pair + of paths: relative-to and base + Version 5.2.1.4 Changed ffi-lib to open libraries in local mode by default diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 9c0eeacb77..a5f5bd34a9 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -466,6 +466,7 @@ EXPORTS scheme_build_path scheme_path_to_directory_path scheme_path_to_complete_path + scheme_simplify_path scheme_make_path scheme_make_sized_path scheme_make_sized_offset_path diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 15e827c87e..b8f240864e 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -481,6 +481,7 @@ EXPORTS scheme_build_path scheme_path_to_directory_path scheme_path_to_complete_path + scheme_simplify_path scheme_make_path scheme_make_sized_path scheme_make_sized_offset_path diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 96ca0f86fa..86081229a6 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -483,6 +483,7 @@ scheme_split_path scheme_build_path scheme_path_to_directory_path scheme_path_to_complete_path +scheme_simplify_path scheme_make_path scheme_make_sized_path scheme_make_sized_offset_path diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 7039b47a05..13c402b876 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -489,6 +489,7 @@ scheme_split_path scheme_build_path scheme_path_to_directory_path scheme_path_to_complete_path +scheme_simplify_path scheme_make_path scheme_make_sized_path scheme_make_sized_offset_path diff --git a/src/racket/src/file.c b/src/racket/src/file.c index 332665114d..54353d8b73 100644 --- a/src/racket/src/file.c +++ b/src/racket/src/file.c @@ -192,7 +192,6 @@ static Scheme_Object *absolute_path_p(int argc, Scheme_Object **argv); static Scheme_Object *complete_path_p(int argc, Scheme_Object **argv); static Scheme_Object *path_to_complete_path(int argc, Scheme_Object **argv); static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[]); -static Scheme_Object *simplify_path(int argc, Scheme_Object *argv[]); static Scheme_Object *cleanse_path(int argc, Scheme_Object *argv[]); static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[]); static Scheme_Object *current_drive(int argc, Scheme_Object *argv[]); @@ -455,7 +454,7 @@ void scheme_init_file(Scheme_Env *env) 1, 1), env); scheme_add_global_constant("simplify-path", - scheme_make_prim_w_arity(simplify_path, + scheme_make_prim_w_arity(scheme_simplify_path, "simplify-path", 1, 2), env); @@ -4672,7 +4671,7 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle return path; } -static Scheme_Object *simplify_path(int argc, Scheme_Object *argv[]) +Scheme_Object *scheme_simplify_path(int argc, Scheme_Object *argv[]) { char *s; int len, use_fs, kind; @@ -5093,9 +5092,15 @@ static Scheme_Object *explode_path(Scheme_Object *p) Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir) { - Scheme_Object *de, *oe; + Scheme_Object *de, *be, *oe; - de = explode_path(dir); + if (SCHEME_PAIRP(dir)) { + be = explode_path(SCHEME_CAR(dir)); + de = explode_path(SCHEME_CDR(dir)); + } else { + be = explode_path(dir); + de = be; + } oe = explode_path(obj); while (SCHEME_PAIRP(de) @@ -5104,11 +5109,19 @@ Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir return obj; de = SCHEME_CDR(de); oe = SCHEME_CDR(oe); + be = SCHEME_CDR(be); } if (SCHEME_NULLP(de)) { Scheme_Object *a[2]; - + + while (SCHEME_PAIRP(be) + && SCHEME_PAIRP(oe) + && scheme_equal(SCHEME_CAR(be), SCHEME_CAR(oe))) { + oe = SCHEME_CDR(oe); + be = SCHEME_CDR(be); + } + if (SCHEME_NULLP(oe)) { a[0] = same_symbol; obj = scheme_build_path(1, a); @@ -5123,6 +5136,13 @@ Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir obj = scheme_build_path(2, a); oe = SCHEME_CDR(oe); } + + while (!SCHEME_NULLP(be)) { + a[0] = up_symbol; + a[1] = obj; + obj = scheme_build_path(2, a); + be = SCHEME_CDR(be); + } } return obj; diff --git a/src/racket/src/portfun.c b/src/racket/src/portfun.c index 36207e2d95..3d734bb885 100644 --- a/src/racket/src/portfun.c +++ b/src/racket/src/portfun.c @@ -4562,10 +4562,8 @@ current_load_use_compiled(int argc, Scheme_Object *argv[]) 2, NULL, NULL, 0); } -static Scheme_Object *abs_directory_p(const char *name, int argc, Scheme_Object **argv) +static Scheme_Object *abs_directory_p(const char *name, Scheme_Object *d) { - Scheme_Object *d = argv[0]; - if (!SCHEME_FALSEP(d)) { char *expanded; Scheme_Object *ed; @@ -4597,7 +4595,7 @@ static Scheme_Object *abs_directory_p(const char *name, int argc, Scheme_Object static Scheme_Object *lr_abs_directory_p(int argc, Scheme_Object **argv) { - return abs_directory_p("current-load-relative-directory", argc, argv); + return abs_directory_p("current-load-relative-directory", argv[0]); } static Scheme_Object * @@ -4611,7 +4609,20 @@ current_load_directory(int argc, Scheme_Object *argv[]) static Scheme_Object *wr_abs_directory_p(int argc, Scheme_Object **argv) { - return abs_directory_p("current-write-relative-directory", argc, argv); + if (SCHEME_PAIRP(argv[0])) { + Scheme_Object *a, *d, *r; + a = abs_directory_p("current-write-relative-directory", SCHEME_CAR(argv[0])); + d = abs_directory_p("current-write-relative-directory", SCHEME_CDR(argv[0])); + r = scheme_extract_relative_to(a, d); + if (SAME_OBJ(a, r)) { + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "%s: path: %V does not extend path: %V", + "current-write-relative-directory", + a, d); + } + return scheme_make_pair(a, d); + } else + return abs_directory_p("current-write-relative-directory", argv[0]); } static Scheme_Object * diff --git a/src/racket/src/print.c b/src/racket/src/print.c index 9bc9626b26..149e20e03e 100644 --- a/src/racket/src/print.c +++ b/src/racket/src/print.c @@ -2282,7 +2282,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, dir = scheme_get_param(scheme_current_config(), MZCONFIG_WRITE_DIRECTORY); - if (SCHEME_PATHP(dir)) + if (SCHEME_TRUEP(dir)) obj = scheme_extract_relative_to(obj, dir); print_compact(pp, CPT_PATH); @@ -2301,7 +2301,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, dir = scheme_get_param(scheme_current_config(), MZCONFIG_WRITE_DIRECTORY); - if (SCHEME_PATHP(dir)) + if (SCHEME_TRUEP(dir)) obj = scheme_extract_relative_to(obj, dir); print_utf8_string(pp, "#^", 0, 2); diff --git a/src/racket/src/read.c b/src/racket/src/read.c index 2156912700..9947456009 100644 --- a/src/racket/src/read.c +++ b/src/racket/src/read.c @@ -1325,6 +1325,9 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table * a[0] = params->read_relative_path; a[1] = str; str = scheme_build_path(2, a); + a[0] = str; + a[1] = scheme_false; + str = scheme_simplify_path(2, a); } } diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 10c3b21254..48b37856d2 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -908,6 +908,7 @@ MZ_EXTERN Scheme_Object *scheme_split_path(const char *path, int len, Scheme_Obj MZ_EXTERN Scheme_Object *scheme_build_path(int argc, Scheme_Object **argv); MZ_EXTERN Scheme_Object *scheme_path_to_directory_path(Scheme_Object *p); MZ_EXTERN Scheme_Object *scheme_path_to_complete_path(Scheme_Object *path, Scheme_Object *relto_path); +MZ_EXTERN Scheme_Object *scheme_simplify_path(int argc, Scheme_Object *argv[]); MZ_EXTERN Scheme_Object *scheme_make_path(const char *chars); MZ_EXTERN Scheme_Object *scheme_make_sized_path(char *chars, intptr_t len, int copy); diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 7060f19739..129931ea97 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -747,6 +747,7 @@ Scheme_Object *(*scheme_split_path)(const char *path, int len, Scheme_Object **b Scheme_Object *(*scheme_build_path)(int argc, Scheme_Object **argv); Scheme_Object *(*scheme_path_to_directory_path)(Scheme_Object *p); Scheme_Object *(*scheme_path_to_complete_path)(Scheme_Object *path, Scheme_Object *relto_path); +Scheme_Object *(*scheme_simplify_path)(int argc, Scheme_Object *argv[]); Scheme_Object *(*scheme_make_path)(const char *chars); Scheme_Object *(*scheme_make_sized_path)(char *chars, intptr_t len, int copy); Scheme_Object *(*scheme_make_sized_offset_path)(char *chars, intptr_t d, intptr_t len, int copy); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index a67eb08e1b..82167709fa 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -531,6 +531,7 @@ scheme_extension_table->scheme_build_path = scheme_build_path; scheme_extension_table->scheme_path_to_directory_path = scheme_path_to_directory_path; scheme_extension_table->scheme_path_to_complete_path = scheme_path_to_complete_path; + scheme_extension_table->scheme_simplify_path = scheme_simplify_path; scheme_extension_table->scheme_make_path = scheme_make_path; scheme_extension_table->scheme_make_sized_path = scheme_make_sized_path; scheme_extension_table->scheme_make_sized_offset_path = scheme_make_sized_offset_path; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 60295ea219..f26f22fb6b 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -531,6 +531,7 @@ #define scheme_build_path (scheme_extension_table->scheme_build_path) #define scheme_path_to_directory_path (scheme_extension_table->scheme_path_to_directory_path) #define scheme_path_to_complete_path (scheme_extension_table->scheme_path_to_complete_path) +#define scheme_simplify_path (scheme_extension_table->scheme_simplify_path) #define scheme_make_path (scheme_extension_table->scheme_make_path) #define scheme_make_sized_path (scheme_extension_table->scheme_make_sized_path) #define scheme_make_sized_offset_path (scheme_extension_table->scheme_make_sized_offset_path)