change `current-write-relative-directory' to support more path conversions

In particular, allow a pair of a relative-to directory and a base
directory. Paths that syntactically extend the base directory are
recorded as relative to the relative-to directory (which must
syntactically extend the base directory).

The compilation manager now sets the parameter to a pair with
the base directory as the main collection directory, if the source
file's path extends that directory's path.

This generalization solves problems created by cross-module inlining,
where the source location of a procedure in bytecode can now be in a
different file than the enclosing module's file.

Also add a test that checks whether the build directory shows up
in any ".zo", ".dep", or documentation ".html" files.

Closes PR 12549

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)])
+                          (let* ([dir
-                            (if (eq? base 'relative)
+                                  (let-values ([(base name dir?) (split-path path)])
-                              (current-directory)
+                                    (if (eq? base 'relative)
-                              (path->complete-path base (current-directory))))])
+                                        (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)

collects/scribblings/reference/write.scrbl

@@ -251,16 +251,27 @@ object within @litchar{#<syntax}...@litchar{>} (after the
 
 
 @defparam*[current-write-relative-directory path 
-                                            (or/c (and/c path-string? complete-path?) #f)
+                                            (or/c (and/c path-string? complete-path?) 
-                                            (or/c (and/c path? complete-path?) #f)]{
+                                                  (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
+names. When the parameter's value is a @racket[_path], paths that syntactically extend @racket[_path]
-parameter's value are converted to relative paths; when the resulting
+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].}
 
 
 

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)

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))

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
 

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

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

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

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

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;

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 *

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);

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);
                   }
                 }
 

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);

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);

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;

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)