add `current-compiled-file-roots', PLTCOMPILEDROOTS, and -R/--compiled

The new parameter (and supporting environment variables and
command-line flags) can bytecode lookup to a tree other than
where a source file resides, so that sources and generated
compiled files can be kept separate. It also supports storing
bytecode files in a version-specific location (either with
the source or elsewhere).

collects/compiler/cm.rkt

@@ -66,18 +66,22 @@
                                        p
                                        (rkt->ss p)))]
                        [modes (use-compiled-file-paths)]
+                       [roots (current-compiled-file-roots)]
                        [get-zo-date+mode (lambda (name)
                                            (ormap
-                                            (lambda (mode)
-                                              (let ([v (file-or-directory-modify-seconds
-                                                        (build-path 
-                                                         base
-                                                         mode
-                                                         (path-add-suffix name #".zo"))
-                                                        #f
-                                                        (lambda () #f))])
-                                                (and v (cons v mode))))
-                                            modes))]
+                                            (lambda (root)
+                                              (ormap
+                                               (lambda (mode)
+                                                 (let ([v (file-or-directory-modify-seconds
+                                                           (build-path 
+                                                            (reroot-path* base root)
+                                                            mode
+                                                            (path-add-suffix name #".zo"))
+                                                           #f
+                                                           (lambda () #f))])
+                                                   (and v (list* v mode root))))
+                                               modes))
+                                            roots))]
                        [main-zo-date+mode (and (or p-date (not alt-date))
                                                (get-zo-date+mode name))]
                        [alt-zo-date+mode (and (or alt-date
@@ -88,13 +92,15 @@
                        [zo-date+mode (or main-zo-date+mode alt-zo-date+mode)]
                        [zo-date (and zo-date+mode (car zo-date+mode))]
                        [get-zo-path (lambda ()
-                                      (let-values ([(name mode)
+                                      (let-values ([(name mode root)
                                                     (if main-zo-date+mode
                                                         (values (path-add-suffix name #".zo")
-                                                                (cdr main-zo-date+mode))
+                                                                (cadr main-zo-date+mode)
+                                                                (cddr main-zo-date+mode))
                                                         (values (path-add-suffix (rkt->ss name) #".zo")
-                                                                (cdr alt-zo-date+mode)))])
-                                        (build-path base mode name)))])
+                                                                (cadr alt-zo-date+mode)
+                                                                (cddr alt-zo-date+mode)))])
+                                        (build-path (reroot-path* base root) mode name)))])
                   (cond
                    [(and zo-date
                          (or (not date)
@@ -115,6 +121,15 @@
                 [else 
                  (c-loop (cdr paths))])]))]))))
 
+
+(define (reroot-path* base root)
+  (cond
+   [(eq? root 'same) base]
+   [(relative-path? root)
+    (build-path base root)]
+   [else
+    (reroot-path base root)]))
+
 (define (trace-printf fmt . args)
   (let ([t (trace)])
     (unless (eq? t void)
@@ -137,20 +152,45 @@
         (loop subcode ht))))
   (for/list ([k (in-hash-keys ht)]) k))
 
-(define (get-compilation-dir+name mode path)
-  (let-values ([(base name must-be-dir?) (split-path path)])
-    (values 
-     (cond
-       [(eq? 'relative base) mode]
-       [else (build-path base mode)])
-     name)))
+(define (get-compilation-dir+name mode roots path)
+  (define (get-one root)
+    (let-values ([(base name must-be-dir?) (split-path path)])
+      (values 
+       (cond
+        [(eq? 'relative base) 
+         (cond
+          [(eq? root 'same) mode]
+          [else (build-path root mode)])]
+        [else (build-path (cond
+                           [(eq? root 'same) base]
+                           [(relative-path? root) (build-path base root)]
+                           [else (reroot-path base root)])
+                          mode)])
+       name)))
+  ;; Try first root:
+  (define-values (p n) (get-one (car roots)))
+  (if (or (null? (cdr roots))
+          (file-exists? (path-add-suffix (build-path p n) #".zo")))
+      ;; Only root or first has a ".zo" file:
+      (values p n)
+      (let loop ([roots (cdr roots)])
+        (cond
+         [(null? roots) 
+          ;; No roots worked, so assume the first root:
+          (values p n)]
+         [else
+          ;; Check next root:
+          (define-values (p n) (get-one (car roots)))
+          (if (file-exists? (path-add-suffix (build-path p n) #".zo"))
+              (values p n)
+              (loop (cdr roots)))]))))
 
-(define (get-compilation-path mode path)
-  (let-values ([(dir name) (get-compilation-dir+name mode path)])
+(define (get-compilation-path mode roots path)
+  (let-values ([(dir name) (get-compilation-dir+name mode roots path)])
     (build-path dir name)))
 
-(define (get-compilation-dir mode path)
-  (let-values ([(dir name) (get-compilation-dir+name mode path)])
+(define (get-compilation-dir mode roots path)
+  (let-values ([(dir name) (get-compilation-dir+name mode roots path)])
     dir))
 
 (define (touch path)
@@ -170,7 +210,7 @@
     (when noisy? (trace-printf "deleting: ~a" path))
     (with-compiler-security-guard (delete-file path))))
 
-(define (compilation-failure mode path zo-name date-path reason)
+(define (compilation-failure mode roots path zo-name date-path reason)
   (try-delete-file zo-name)
   (trace-printf "failure"))
 
@@ -224,7 +264,7 @@
                                                (get-source-sha1 (path-replace-suffix p #".ss"))))])
     (call-with-input-file* p sha1)))
 
-(define (get-dep-sha1s deps up-to-date read-src-syntax mode must-exist?)
+(define (get-dep-sha1s deps up-to-date read-src-syntax mode roots must-exist?)
   (let ([l (for/fold ([l null]) ([dep (in-list deps)])
              (and l
                   ;; (cons 'ext rel-path) => a non-module file, check source
@@ -239,7 +279,7 @@
                               [else #f]))]
                      [(or (hash-ref up-to-date (simple-form-path p) #f)
                           ;; Use `compiler-root' with `sha1-only?' as #t:
-                          (compile-root mode p up-to-date read-src-syntax #t))
+                          (compile-root mode roots p up-to-date read-src-syntax #t))
                       => (lambda (sh)
                            (cons (cons (cdr sh) dep) l))]
                      [must-exist?
@@ -261,8 +301,8 @@
            ;; compute one hash from all hashes
            (sha1 (open-input-bytes (get-output-bytes p)))))))
 
-(define (write-deps code mode path src-sha1 external-deps reader-deps up-to-date read-src-syntax)
-  (let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")]
+(define (write-deps code mode roots path src-sha1 external-deps reader-deps up-to-date read-src-syntax)
+  (let ([dep-path (path-add-suffix (get-compilation-path mode roots path) #".dep")]
         [deps (remove-duplicates (append (get-deps code path)
                                          reader-deps))]
         [external-deps (remove-duplicates external-deps)])
@@ -275,7 +315,7 @@
                           external-deps))])
         (write (list* (version)
                       (cons (or src-sha1 (get-source-sha1 path))
-                            (get-dep-sha1s deps up-to-date read-src-syntax mode #t))
+                            (get-dep-sha1s deps up-to-date read-src-syntax mode roots #t))
                       deps)
                op)
         (newline op))))))
@@ -305,7 +345,7 @@
   #:property prop:procedure (struct-field-index proc))
 (define-struct file-dependency (path) #:prefab)
 
-(define (compile-zo* mode path src-sha1 read-src-syntax zo-name up-to-date)
+(define (compile-zo* mode roots path src-sha1 read-src-syntax zo-name up-to-date)
   ;; The `path' argument has been converted to .rkt or .ss form,
   ;;  as appropriate.
   ;; External dependencies registered through reader guard and
@@ -375,7 +415,8 @@
       (get-module-code path mode compile
                        (lambda (a b) #f) ; extension handler
                        #:source-reader read-src-syntax)))
-  (define code-dir (get-compilation-dir mode path))
+  (define dest-roots (list (car roots)))
+  (define code-dir (get-compilation-dir mode dest-roots path))
 
   ;; Wait for accomplice logging to finish:
   (log-message accomplice-logger 'info "stop" done-key)
@@ -389,7 +430,7 @@
         (with-handlers ([exn:fail?
                          (lambda (ex)
                            (close-output-port out)
-                           (compilation-failure mode path zo-name #f
+                           (compilation-failure mode dest-roots path zo-name #f
                                                 (exn-message ex))
                            (raise ex))])
           (parameterize ([current-write-relative-directory
@@ -422,7 +463,7 @@
         ;; Note that we check time and write .deps before returning from
         ;; with-compile-output...
         (verify-times path tmp-name)
-        (write-deps code mode path src-sha1 external-deps reader-deps up-to-date read-src-syntax)))))
+        (write-deps code mode dest-roots path src-sha1 external-deps reader-deps up-to-date read-src-syntax)))))
 
 (define (install-module-hashes! s start len)
   (define vlen (bytes-ref s (+ start 2)))
@@ -463,14 +504,14 @@
             alt-path
             path))))
 
-(define (maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)
+(define (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date)
   (let ([actual-path (actual-source-path orig-path)])
     (unless sha1-only?
       ((manager-compile-notify-handler) actual-path)
       (trace-printf "compiling: ~a" actual-path))
     (begin0
      (parameterize ([indent (string-append "  " (indent))])
-       (let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
+       (let* ([zo-name (path-add-suffix (get-compilation-path mode roots path) #".zo")]
               [zo-exists? (file-exists? zo-name)])
          (if (and zo-exists? (trust-existing-zos))
              (begin
@@ -488,7 +529,7 @@
                (if (and zo-exists?
                         src-sha1
                         (equal? src-sha1 (caadr deps))
-                        (equal? (get-dep-sha1s (cddr deps) up-to-date read-src-syntax mode #f)
+                        (equal? (get-dep-sha1s (cddr deps) up-to-date read-src-syntax mode roots #f)
                                 (cdadr deps)))
                    (begin
                      (log-info (format "cm: ~ahash-equivalent ~a" 
@@ -517,11 +558,11 @@
                                 (with-handlers
                                     ([exn:get-module-code?
                                       (lambda (ex)
-                                        (compilation-failure mode path zo-name
+                                        (compilation-failure mode roots path zo-name
                                                              (exn:get-module-code-path ex)
                                                              (exn-message ex))
                                         (raise ex))])
-                                  (compile-zo* mode path src-sha1 read-src-syntax zo-name up-to-date)))
+                                  (compile-zo* mode roots path src-sha1 read-src-syntax zo-name up-to-date)))
                               (log-info (format "cm: ~acompiled  ~a" 
                                                 (build-string 
                                                  (depth)
@@ -533,8 +574,8 @@
      (unless sha1-only?
        (trace-printf "end compile: ~a" actual-path)))))
 
-(define (get-compiled-time mode path)
-  (define-values (dir name) (get-compilation-dir+name mode path))
+(define (get-compiled-time mode roots path)
+  (define-values (dir name) (get-compilation-dir+name mode roots path))
   (or (try-file-time (build-path dir "native" (system-library-subpath)
                                  (path-add-suffix name (system-type
                                                         'so-suffix))))
@@ -550,8 +591,8 @@
         (with-handlers ([exn:fail:filesystem? (lambda (exn) "")])
           (call-with-input-file* dep-path (lambda (p) (cdadr (read p))))))))))
 
-(define (get-compiled-sha1 mode path)
-  (define-values (dir name) (get-compilation-dir+name mode path))
+(define (get-compiled-sha1 mode roots path)
+  (define-values (dir name) (get-compilation-dir+name mode roots path))
   (let ([dep-path (build-path dir (path-add-suffix name #".dep"))])
     (or (try-file-sha1 (build-path dir "native" (system-library-subpath)
                                    (path-add-suffix name (system-type
@@ -567,14 +608,14 @@
         (path-replace-suffix p #".ss")
         p)))
 
-(define (compile-root mode path0 up-to-date read-src-syntax sha1-only?)
+(define (compile-root mode roots path0 up-to-date read-src-syntax sha1-only?)
   (define orig-path (simple-form-path path0))
   (define (read-deps path)
     (with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version) '#f))])
       (with-module-reading-parameterization
        (lambda ()
          (call-with-input-file
-             (path-add-suffix (get-compilation-path mode path) #".dep")
+             (path-add-suffix (get-compilation-path mode roots path) #".dep")
            read)))))
   (define (do-check)
     (let* ([main-path orig-path]
@@ -585,13 +626,13 @@
                                (try-file-time alt-path))]
            [path (if alt-path-time alt-path main-path)]
            [path-time (or main-path-time alt-path-time)]
-           [path-zo-time (get-compiled-time mode path)])
+           [path-zo-time (get-compiled-time mode roots path)])
       (cond
        [(not path-time)
         (trace-printf "~a does not exist" orig-path)
         (or (hash-ref up-to-date orig-path #f)
             (let ([stamp (cons path-zo-time
-                               (delay (get-compiled-sha1 mode path)))])
+                               (delay (get-compiled-sha1 mode roots path)))])
               (hash-set! up-to-date main-path stamp)
               (unless (eq? main-path alt-path)
                 (hash-set! up-to-date alt-path stamp))
@@ -603,11 +644,11 @@
              [(not (and (pair? deps) (equal? (version) (car deps))))
               (lambda ()
                 (trace-printf "newer version...")
-                (maybe-compile-zo #f #f mode path orig-path read-src-syntax up-to-date))]
+                (maybe-compile-zo #f #f mode roots path orig-path read-src-syntax up-to-date))]
              [(> path-time path-zo-time)
               (trace-printf "newer src...")
               ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
-              (maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)]
+              (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date)]
              [(ormap
                (lambda (p)
                  ;; (cons 'ext rel-path) => a non-module file (check date)
@@ -617,7 +658,7 @@
                  (define t
                    (if ext?
                        (cons (try-file-time d) #f)
-                       (compile-root mode d up-to-date read-src-syntax #f)))
+                       (compile-root mode roots d up-to-date read-src-syntax #f)))
                  (and (car t)
                       (> (car t) path-zo-time)
                       (begin (trace-printf "newer: ~a (~a > ~a)..."
@@ -625,14 +666,14 @@
                              #t)))
                (cddr deps))
               ;; If `sha1-only?', then `maybe-compile-zo' returns a #f or thunk:
-              (maybe-compile-zo sha1-only? deps mode path orig-path read-src-syntax up-to-date)]
+              (maybe-compile-zo sha1-only? deps mode roots path orig-path read-src-syntax up-to-date)]
              [else #f]))
           (cond
            [(and build sha1-only?) #f]
            [else
             (when build (build))
-            (let ([stamp (cons (get-compiled-time mode path)
-                               (delay (get-compiled-sha1 mode path)))])
+            (let ([stamp (cons (get-compiled-time mode roots path)
+                               (delay (get-compiled-sha1 mode roots path)))])
               (hash-set! up-to-date main-path stamp)
               (unless (eq? main-path alt-path)
                 (hash-set! up-to-date alt-path stamp))
@@ -657,6 +698,7 @@
                        #f
                        #:security-guard security-guard)])
         (compile-root (car (use-compiled-file-paths))
+                      (current-compiled-file-roots)
                       (path->complete-path src)
                       cache
                       read-src-syntax
@@ -675,7 +717,8 @@
         [orig-load (current-load)]
         [orig-registry (namespace-module-registry (current-namespace))]
         [default-handler (current-load/use-compiled)]
-        [modes (use-compiled-file-paths)])
+        [modes (use-compiled-file-paths)]
+        [roots (current-compiled-file-roots)])
     (define (compilation-manager-load-handler path mod-name)
       (cond [(or (not mod-name)
                  ;; Don't trigger compilation if we're not supposed to work with source:
@@ -688,8 +731,8 @@
                              (file-exists? p2)))))
              (trace-printf "skipping:  ~a file does not exist" path)
              (when delete-zos-when-rkt-file-does-not-exist?
-               (unless (null? modes)
-                 (define to-delete (path-add-suffix (get-compilation-path (car modes) path) #".zo")) 
+               (unless (or (null? modes) (null? roots))
+                 (define to-delete (path-add-suffix (get-compilation-path (car modes) (car roots) path) #".zo")) 
                  (when (file-exists? to-delete)
                    (trace-printf "deleting:  ~s" to-delete)
                    (with-compiler-security-guard (delete-file to-delete)))))]
@@ -700,6 +743,11 @@
                            path 
                            (use-compiled-file-paths)
                            (car modes))]
+            [(not (equal? roots (current-compiled-file-roots)))
+             (trace-printf "skipping:  ~a current-compiled-file-roots changed; current value ~s, original was ~s"
+                           path 
+                           (current-compiled-file-roots)
+                           roots)]
             [(not (eq? compilation-manager-load-handler
                        (current-load/use-compiled)))
              (trace-printf "skipping:  ~a current-load/use-compiled changed ~s"
@@ -718,13 +766,17 @@
             [else
              (trace-printf "processing: ~a" path)
              (parameterize ([compiler-security-guard security-guard])
-               (compile-root (car modes) path cache read-syntax #f))
+               (compile-root (car modes) roots path cache read-syntax #f))
              (trace-printf "done: ~a" path)])
       (default-handler path mod-name))
     (when (null? modes)
       (raise-mismatch-error 'make-compilation-manager-...
                             "empty use-compiled-file-paths list: "
                             modes))
+    (when (null? roots)
+      (raise-mismatch-error 'make-compilation-manager-...
+                            "empty current-compiled-file-roots list: "
+                            roots))
     compilation-manager-load-handler))
 
 

collects/racket/private/misc.rkt

@@ -187,7 +187,8 @@
 
   (#%provide define-syntax-rule
              rationalize 
-             path-string? path-replace-suffix path-add-suffix normal-case-path
+             path-string? path-replace-suffix path-add-suffix 
+             normal-case-path reroot-path
              read-eval-print-loop
              load/cd
              load-relative load-relative-extension

collects/scribblings/reference/eval.scrbl

@@ -255,8 +255,15 @@ X) files.
 The check for a compiled file occurs whenever the given path
 @racket[_file] ends with any extension (e.g., @filepath{.rkt} or
 @filepath{.scrbl}), and the check consults the subdirectories
-indicated by the @racket[use-compiled-file-paths] parameter relative
-to @racket[_file].  The subdirectories are checked in order. A
+indicated by the @racket[current-compiled-file-roots] and
+@racket[use-compiled-file-paths] parameters relative to
+@racket[_file], where the former supplies ``roots'' for compiled files
+and the latter provides subdirectories. A ``root'' can be an absolute
+path, in which case @racket[_file]'s directory is combined with
+@racket[reroot-path] and the root as the second argument; if the
+``root'' is a relative path, then the relative path is instead
+suffixed onto the directory of @racket[_file]. The roots are tried in
+order, and the subdirectories are checked in order within each root. A
 @filepath{.zo} version of the file (whose name is formed by passing
 @racket[_file] and @racket[#".zo"] to @racket[path-add-suffix]) is
 loaded if it exists directly in one of the indicated subdirectories,
@@ -331,6 +338,23 @@ A list of relative paths, which defaults to @racket[(list
 handler} (see @racket[current-load/use-compiled]).}
 
 
+@defparam*[current-compiled-file-roots paths (listof (or/c path-string? 'same)) (listof (or/c path? 'path))]{
+
+A list of paths and @racket['same]s that is is used by the default
+@tech{compiled-load handler} (see @racket[current-load/use-compiled]).
+
+The parameter is normally initialized to @racket[(list 'same)], but
+the parameter's initial value can be adjusted by the
+@as-index{@envvar{PLTCOMPILEDROOTS}} environment variable or the
+@DFlag{compiled} or @Flag{R} command-line flag for @exec{racket}.  If
+the environment variable is defined and not overridden by a
+command-line flag, it is parsed by first replacing any
+@litchar["@(version)"] with the result of @racket[(version)], then using
+@racket[path-list-string->path-list] with a default path list
+@racket[(list (build-path 'same))] to arrive at the parameter's
+initial value.}
+
+
 @defproc[(read-eval-print-loop) any]{
 
 Starts a new @deftech{REPL} using the current input, output, and error

collects/scribblings/reference/paths.scrbl

@@ -292,7 +292,7 @@ does not access the filesystem.}
 
 @defproc[(complete-path? [path (or/c path-string? path-for-some-system?)]) boolean?]{
 
-Returns @racket[#t] if @racket[path] is a completely determined path
+Returns @racket[#t] if @racket[path] is a @deftech{complete}ly determined path
 (@italic{not} relative to a directory or drive), @racket[#f]
 otherwise. The @racket[path] argument can be a path for any
 platform. Note that for Windows paths, an absolute path can omit the
@@ -500,6 +500,32 @@ Similar to @racket[path-replace-suffix], but any existing suffix on
 @tech{path element} with @litchar{_}, and then the @racket[suffix] is added
 to the end.}
 
+
+@defproc[(reroot-path [path (or/c path-string? path-for-some-system?)]
+                      [root-path (or/c path-string? path-for-some-system?)])
+         path-for-some-system?]{
+
+Produces a path that extends @racket[root-path] based on the complete
+form of @racket[path].
+
+If @racket[path] is not already @tech{complete}, is it completed via
+@racket[path->complete-path], in which case @racket[path] must be a
+path for the current platform. The @racket[path] argument is also
+@tech{cleanse}d and case-normalized via @racket[normal-case-path]. The
+path is then appended to @racket[root-path]; in the case of Windows
+paths, a root letter drive becomes a letter path element, while a root
+UNC path is prefixed with @racket["UNC"] as a path element and the
+machine and volume names become path elements.
+
+@examples[
+(reroot-path (bytes->path #"/home/caprica/baltar" 'unix)
+             (bytes->path #"/earth" 'unix))
+(reroot-path (bytes->path #"c:\\usr\\adama" 'windows)
+             (bytes->path #"\\\\earth\\africa\\" 'windows))
+(reroot-path (bytes->path #"\\\\galactica\\cac\\adama" 'windows)
+             (bytes->path #"s:\\earth\\africa\\" 'windows))
+]}
+
 @;------------------------------------------------------------------------
 @section{More Path Utilities}
 

collects/scribblings/reference/startup.scrbl

@@ -267,6 +267,13 @@ flags:
         the @Flag{S}/@DFlag{dir} flag is supplied multiple times, the
         search order is as supplied.}
 
+  @item{@FlagFirst{R} @nonterm{paths} or @DFlagFirst{compiled}
+        @nonterm{paths} : Sets the initial value of the
+        @racket[current-compiled-file-roots] parameter, overriding
+        any @envvar{PLTCOMPILEDROOTS} setting. The @nonterm{paths}
+        argument is parsed in the same way as @envvar{PLTCOMPILEDROOTS}
+        (see @racket[current-compiled-file-roots]).}
+
   @item{@FlagFirst{A} @nonterm{dir} or @DFlagFirst{addon}
         @nonterm{dir} : Sets the directory that is returned by
         @racket[(find-system-path 'addon-dir)].}

collects/syntax/modcode.rkt

@@ -11,7 +11,9 @@
 
   (provide/contract
    [get-module-code (->* (path?)
-                         (#:submodule-path
+                         (#:roots
+                          (listof (or/c path? 'same))
+                          #:submodule-path
                           (listof symbol?)
                           #:sub-path 
                           (and/c path-string? relative-path?)
@@ -79,6 +81,7 @@
   (define-struct (exn:get-module-code exn:fail) (path))
 
   (define (get-module-code path
+                           #:roots [roots (current-compiled-file-roots)]
                            #:submodule-path [submodule-path '()]
                            #:sub-path [sub-path0 "compiled"]
                            #:compile [compile0 compile]
@@ -112,6 +115,20 @@
                                        orig-path
                                        (build-path base alt-file)))]
                   [(base) (if (eq? base 'relative) 'same base)])
+      (define (build-found-path base . args)
+        (cond
+         [(or (equal? roots '(same)) (null? roots))
+          (apply build-path base args)]
+         [else
+          (let ([reroot-path* (lambda (base root)
+                                (cond
+                                 [(eq? root 'same) base]
+                                 [(relative-path? root) (build-path base root)]
+                                 [else (reroot-path base root)]))])
+            (or (for/or ([root (in-list (if (null? (cdr roots)) null roots))])
+                  (define p (apply build-path (reroot-path* base root) args))
+                  (and (file-exists? p) p))
+                (apply build-path (reroot-path* base (car roots)) args)))]))
       (let* ([main-path-d (file-or-directory-modify-seconds orig-path #f (lambda () #f))]
              [alt-path-d (and alt-path
                               (not main-path-d)
@@ -121,13 +138,13 @@
              [path (if alt-path-d alt-path main-path)]
              [try-alt? (and alt-file (not alt-path-d) (not main-path-d))]
              [get-so (lambda (file)
-                       (build-path
+                       (build-found-path
                         base sub-path "native"
                         (system-library-subpath)
                         (path-add-suffix file (system-type 'so-suffix))))]
-             [zo (build-path base sub-path (path-add-suffix file #".zo"))]
+             [zo (build-found-path base sub-path (path-add-suffix file #".zo"))]
              [alt-zo (and try-alt?
-                          (build-path base sub-path (path-add-suffix alt-file #".zo")))]
+                          (build-found-path base sub-path (path-add-suffix alt-file #".zo")))]
              [so (get-so file)]
              [alt-so (and try-alt? (get-so alt-file))]
              [with-dir (lambda (t)
@@ -156,6 +173,7 @@
           ;; Use .zo, if it's new enough
           [(or (eq? prefer 'zo)
                (and (not prefer)
+                    (pair? roots)
                     (or (date>=? zo path-d)
                         (and try-alt?
                              (date>=? alt-zo path-d)))))
@@ -172,6 +190,7 @@
           [(and (null? submodule-path)
                 (or (eq? prefer 'so)
                     (and (not prefer)
+                         (pair? roots)
                          (or (date>=? so path-d)
                              (and try-alt?
                                   (date>=? alt-so path-d))))))

collects/syntax/scribblings/modcode.scrbl

@@ -9,6 +9,7 @@
                           [#:submodule-path submodule-path (listof symbol?) '()]
                           [#:sub-path compiled-subdir0 (and/c path-string? relative-path?) "compiled"]
                           [compiled-subdir (and/c path-string? relative-path?) compiled-subdir0]
+                          [#:roots roots (listof (or/c path-string? 'same)) (current-compiled-file-roots)]
                           [#:compile compile-proc0 (any/c . -> . any) compile] 
                           [compile-proc (any/c . -> . any) compile-proc0] 
                           [#:extension-handler ext-proc0 (or/c false/c (path? boolean? . -> . any)) #f]
@@ -31,7 +32,8 @@ submodule.
 
 The @racket[compiled-subdir] argument defaults to @racket["compiled"];
 it specifies the sub-directory to search for a compiled version of the
-module.
+module. The @racket[roots] list specifies a compiled-file search path
+in the same way as the @racket[current-compiled-file-roots] parameter.
 
 The @racket[compile-proc] argument defaults to @racket[compile]. This
 procedure is used to compile module source if an already-compiled

collects/tests/racket/path.rktl

@@ -877,4 +877,31 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(let ([reroot-path/u
+       (lambda (a b)
+         (bytes->string/utf-8
+          (path->bytes
+           (reroot-path (bytes->path (string->bytes/utf-8 a) 'unix)
+                        (bytes->path (string->bytes/utf-8 b) 'unix)))))])
+  (test "b/x/a" reroot-path/u "/x/a" "b")
+  (test "b" reroot-path/u "/" "b")
+  (test "b/x/y/z" reroot-path/u "//x//y//z" "b")
+  (test "/tmp/b/x/y/z" reroot-path/u "//x//y//z" "/tmp/b"))
+
+(let ([reroot-path/w
+       (lambda (a b)
+         (bytes->string/utf-8
+          (path->bytes
+           (reroot-path (bytes->path (string->bytes/utf-8 a) 'windows)
+                        (bytes->path (string->bytes/utf-8 b) 'windows)))))])
+  (test "b\\c\\x\\a" reroot-path/w "c:/x/a" "b")
+  (test "b\\z\\" reroot-path/w "z:/" "b")
+  (test "b\\UNC\\machine\\folder\\a" reroot-path/w "//machine/folder/a" "b")
+  (test "q:/tmp/b\\x\\y\\z" reroot-path/w "x://y//z" "q:/tmp/b")
+  (test "\\\\?\\q:\\tmp\\b\\c\\x/y" reroot-path/w "\\\\?\\c:\\x/y" "q:/tmp/b")
+  (test "\\\\?\\q:\\tmp\\b\\UNC\\machine\\path\\x/y\\z" 
+        reroot-path/w "\\\\?\\UNC\\machine\\path\\x/y\\z" "q:/tmp/b"))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (report-errs)

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,7 @@
+Version 5.3.0.24
+Added PLTCOMPILEDROOTS and --compiled/-R command-line flag
+Added `reroot-path'
+
 Version 5.3.0.23
 Changed make-log-receiver to accept a logger name as an
  event filter

src/racket/cmdline.inc

@@ -684,6 +684,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
   Scheme_Object *sch_argv;
   int skip_coll_dirs = 0;
   Scheme_Object *collects_path = NULL, *collects_extra = NULL, *addon_dir = NULL;
+  char *compiled_paths = NULL;
   Scheme_Object *links_file = NULL;
 #ifndef NO_FILE_SYSTEM_UTILS
   Scheme_Object *collects_paths_l, *collects_paths_r;
@@ -958,6 +959,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
       argv[0] = "-X";
     else if (!strcmp("--search", argv[0]))
       argv[0] = "-S";
+    else if (!strcmp("--compiled", argv[0]))
+      argv[0] = "-R";
     else if (!strcmp("--addon", argv[0]))
       argv[0] = "-A";
     else if (!strcmp("--links", argv[0]))
@@ -1013,6 +1016,17 @@ static int run_from_cmd_line(int argc, char *_argv[],
             collects_path = check_make_path(prog, real_switch, argv[0]);
           was_config_flag = 1;
 	  break;
+        case 'R':
+          if (argc < 2) {
+	    PRINTF("%s: missing path after %s switch\n", 
+		   prog, real_switch);
+	    goto show_need_help;
+	  }
+	  argv++;
+	  --argc;
+	  compiled_paths = argv[0];
+          was_config_flag = 1;
+	  break;
 	case 'A':
 	  if (argc < 2) {
 	    PRINTF("%s: missing path after %s switch\n", 
@@ -1394,6 +1408,15 @@ static int run_from_cmd_line(int argc, char *_argv[],
   if (no_compiled)
     scheme_set_compiled_file_paths(scheme_make_null());
 
+#ifndef NO_FILE_SYSTEM_UTILS
+  /* Setup compiled-file search path: */
+# ifdef GETENV_FUNCTION
+  if (!compiled_paths) {
+    compiled_paths = getenv("PLTCOMPILEDROOTS");
+  }
+# endif
+#endif /* NO_FILE_SYSTEM_UTILS */
+
 #ifndef NO_FILE_SYSTEM_UTILS
   /* Setup path for "addon" directory: */
 # ifdef GETENV_FUNCTION
@@ -1436,6 +1459,8 @@ static int run_from_cmd_line(int argc, char *_argv[],
 #ifndef NO_FILE_SYSTEM_UTILS
   if (!skip_coll_dirs)
     scheme_init_collection_paths_post(global_env, collects_paths_l, collects_paths_r);
+  if (compiled_paths)
+    scheme_init_compiled_roots(global_env, compiled_paths);
 #endif
 
   scheme_seal_parameters();
@@ -1519,6 +1544,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
 	 "  -X <dir>, --collects <dir> : Main collects at <dir> (or \"\" disables all)\n"
 	 "  -S <dir>, --search <dir> : More collects at <dir> (after main collects)\n"
 	 "  -A <dir>, --addon <dir> : Addon directory at <dir>\n"
+         "  -R <paths>, --compiled <paths> : Set compiled-file search roots to <paths>\n"
 	 "  -C <file>, --links <file> : User-specific collection links at <file>\n"
 	 "  -U, --no-user-path : Ignore user-specific collects, etc.\n"
 	 "  -N <file>, --name <file> : Sets `(find-system-path 'run-file)' to <file>\n"

src/racket/include/scheme.h

@@ -1281,6 +1281,7 @@ enum {
   MZCONFIG_CODE_INSPECTOR,
 
   MZCONFIG_USE_COMPILED_KIND,
+  MZCONFIG_USE_COMPILED_ROOTS,
   MZCONFIG_USE_USER_PATHS,
   MZCONFIG_USE_LINK_PATHS,
 
@@ -1836,9 +1837,11 @@ MZ_EXTERN void scheme_set_addon_dir(Scheme_Object *p);
 MZ_EXTERN void scheme_set_links_file(Scheme_Object *p);
 MZ_EXTERN void scheme_set_command_line_arguments(Scheme_Object *vec);
 MZ_EXTERN void scheme_set_compiled_file_paths(Scheme_Object *list);
+MZ_EXTERN void scheme_set_compiled_file_roots(Scheme_Object *list);
 
 MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs);
 MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs);
+MZ_EXTERN void scheme_init_compiled_roots(Scheme_Env *global_env, const char *paths);
 
 MZ_EXTERN void scheme_seal_parameters();
 

src/racket/src/eval.c

@@ -5227,6 +5227,8 @@ void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *ex
       a[0] = _scheme_apply(flcp, 2, a);
       _scheme_apply(clcp, 1, a);
     }
+  } else {
+    scheme_clear_escape();
   }
   p->error_buf = save;
 }
@@ -5236,6 +5238,40 @@ void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_d
   scheme_init_collection_paths_post(global_env, extra_dirs, scheme_null);
 }
 
+void scheme_init_compiled_roots(Scheme_Env *global_env, const char *paths)
+{
+  mz_jmp_buf * volatile save, newbuf;
+  Scheme_Thread * volatile p;
+  p = scheme_get_current_thread();
+  save = p->error_buf;
+  p->error_buf = &newbuf;
+  if (!scheme_setjmp(newbuf)) {
+    Scheme_Object *rr, *ccfr, *pls2pl, *a[3];
+
+    rr = scheme_builtin_value("regexp-replace*");
+    ccfr = scheme_builtin_value("current-compiled-file-roots");
+    pls2pl = scheme_builtin_value("path-list-string->path-list");
+
+    if (rr && ccfr && pls2pl) {
+      a[0] = scheme_make_utf8_string("@[(]version[)]");
+      a[1] = scheme_make_utf8_string(paths);
+      a[2] = scheme_make_utf8_string(scheme_version());
+      a[2] = _scheme_apply(rr, 3, a);
+
+      a[0] = scheme_intern_symbol("same");
+      a[1] = scheme_build_path(1, a);
+
+      a[0] = a[2];
+      a[1] = scheme_make_pair(a[1], scheme_null);
+      a[0] = _scheme_apply(pls2pl, 2, a);
+      _scheme_apply(ccfr, 1, a);
+    }
+  } else {
+    scheme_clear_escape();
+  }
+  p->error_buf = save;  
+}
+
 static Scheme_Object *allow_set_undefined(int argc, Scheme_Object **argv)
 {
   return scheme_param_config("compile-allow-set!-undefined", 

src/racket/src/file.c

@@ -201,6 +201,7 @@ static Scheme_Object *file_identity(int argc, Scheme_Object *argv[]);
 static Scheme_Object *file_size(int argc, Scheme_Object *argv[]);
 static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]);
 static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]);
+static Scheme_Object *compiled_file_roots(int, Scheme_Object *[]);
 static Scheme_Object *use_user_paths(int, Scheme_Object *[]);
 static Scheme_Object *use_link_paths(int, Scheme_Object *[]);
 static Scheme_Object *find_system_path(int argc, Scheme_Object **argv);
@@ -548,6 +549,11 @@ void scheme_init_file(Scheme_Env *env)
 						       "use-compiled-file-paths",
 						       MZCONFIG_USE_COMPILED_KIND),
 			     env);
+  scheme_add_global_constant("current-compiled-file-roots",
+			     scheme_register_parameter(compiled_file_roots,
+						       "current-compiled-file-roots",
+						       MZCONFIG_USE_COMPILED_ROOTS),
+			     env);
   scheme_add_global_constant("use-user-specific-search-paths",
 			     scheme_register_parameter(use_user_paths,
 						       "use-user-specific-search-paths",
@@ -5839,7 +5845,7 @@ static Scheme_Object *current_directory(int argc, Scheme_Object **argv)
 
 #endif
 
-static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
+static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel_ok, int abs_ok, int sym_ok)
 {
   Scheme_Object *v = argv[0];
 
@@ -5852,17 +5858,21 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
   while (SCHEME_PAIRP(v)) {
     Scheme_Object *s;
     s = SCHEME_CAR(v);
-    if (!SCHEME_PATH_STRINGP(s))
-      return NULL;
-    s = TO_PATH(s);
-    if (rel && !scheme_is_relative_path(SCHEME_PATH_VAL(s),
-					SCHEME_PATH_LEN(s),
-                                        SCHEME_PLATFORM_PATH_KIND))
-      return NULL;
-    if (!rel && !scheme_is_complete_path(SCHEME_PATH_VAL(s),
-					 SCHEME_PATH_LEN(s),
-                                         SCHEME_PLATFORM_PATH_KIND))
-      return NULL;
+    if (sym_ok && SAME_OBJ(s, same_symbol)) {
+      /* ok */
+    } else {
+      if (!SCHEME_PATH_STRINGP(s))
+        return NULL;
+      s = TO_PATH(s);
+      if (!abs_ok && !scheme_is_relative_path(SCHEME_PATH_VAL(s),
+                                              SCHEME_PATH_LEN(s),
+                                              SCHEME_PLATFORM_PATH_KIND))
+        return NULL;
+      if (!rel_ok && !scheme_is_complete_path(SCHEME_PATH_VAL(s),
+                                              SCHEME_PATH_LEN(s),
+                                              SCHEME_PLATFORM_PATH_KIND))
+        return NULL;
+    }
     v = SCHEME_CDR(v);
   }
 
@@ -5875,7 +5885,8 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
     v = argv[0];
     while (SCHEME_PAIRP(v)) {
       s = SCHEME_CAR(v);
-      s = TO_PATH(s);
+      if (!SCHEME_SYMBOLP(s))
+        s = TO_PATH(s);
       
       p = scheme_make_pair(s, scheme_null);
       if (!first)
@@ -5895,7 +5906,7 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
 
 static Scheme_Object *collpaths_p(int argc, Scheme_Object **argv)
 {
-  return collpaths_gen_p(argc, argv, 0);
+  return collpaths_gen_p(argc, argv, 0, 1, 0);
 }
 
 Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) {
@@ -5914,7 +5925,7 @@ static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *
 
 static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv)
 {
-  return collpaths_gen_p(argc, argv, 1);
+  return collpaths_gen_p(argc, argv, 1, 0, 0);
 }
 
 static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
@@ -5925,6 +5936,24 @@ static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
 			     -1, compiled_kind_p, "list of relative paths and strings", 1);
 }
 
+static Scheme_Object *compiled_roots_p(int argc, Scheme_Object **argv)
+{
+  return collpaths_gen_p(argc, argv, 1, 1, 1);
+}
+
+Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[])
+{
+  return compiled_file_roots(argc, argv);
+}
+
+static Scheme_Object *compiled_file_roots(int argc, Scheme_Object *argv[])
+{
+  return scheme_param_config("current-compiled-file-roots",
+			     scheme_make_integer(MZCONFIG_USE_COMPILED_ROOTS),
+			     argc, argv,
+			     -1, compiled_roots_p, "list of paths, string, and 'same", 1);
+}
+
 static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[])
 {
   return scheme_param_config("use-user-specific-search-paths", 

src/racket/src/place.c

@@ -201,6 +201,7 @@ typedef struct Place_Start_Data {
   Scheme_Object *function;
   Scheme_Object *channel;
   Scheme_Object *current_library_collection_paths;
+  Scheme_Object *compiled_roots;
   mzrt_sema *ready;  /* malloc'ed item */
   struct Scheme_Place_Object *place_obj;   /* malloc'ed item */
   struct NewGC *parent_gc;
@@ -361,6 +362,10 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) {
   collection_paths = places_deep_copy_to_master(collection_paths);
   place_data->current_library_collection_paths = collection_paths;
 
+  collection_paths = scheme_compiled_file_roots(0, NULL);
+  collection_paths = places_deep_copy_to_master(collection_paths);
+  place_data->compiled_roots = collection_paths;
+
   cust = scheme_get_current_custodian();
   mem_limit = GC_get_account_memory_limit(cust);
   place_data->cust_limit = scheme_make_integer(mem_limit);
@@ -2504,6 +2509,8 @@ static void *place_start_proc_after_stack(void *data_arg, void *stack_base) {
 
   a[0] = places_deep_uncopy(place_data->current_library_collection_paths);
   scheme_current_library_collection_paths(1, a);
+  a[0] = places_deep_uncopy(place_data->compiled_roots);
+  scheme_compiled_file_roots(1, a);
   scheme_seal_parameters();
 
   a[0] = places_deep_uncopy(place_data->module);

src/racket/src/portfun.c

@@ -159,6 +159,7 @@ READ_ONLY Scheme_Object *scheme_display_proc;
 READ_ONLY Scheme_Object *scheme_print_proc;
 
 SHARED_OK Scheme_Object *initial_compiled_file_paths;
+SHARED_OK Scheme_Object *initial_compiled_file_roots;
 
 THREAD_LOCAL_DECL(static Scheme_Object *dummy_input_port);
 THREAD_LOCAL_DECL(static Scheme_Object *dummy_output_port);
@@ -346,6 +347,10 @@ void scheme_init_port_fun_config(void)
     scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, initial_compiled_file_paths);
   else
     scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, scheme_make_pair(scheme_make_path("compiled"), scheme_null));
+  if (initial_compiled_file_roots)
+    scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, initial_compiled_file_roots);
+  else
+    scheme_set_root_param(MZCONFIG_USE_COMPILED_ROOTS, scheme_make_pair(scheme_intern_symbol("same"), scheme_null));
   scheme_set_root_param(MZCONFIG_USE_USER_PATHS, (scheme_ignore_user_paths ? scheme_false : scheme_true));
   scheme_set_root_param(MZCONFIG_USE_LINK_PATHS, (scheme_ignore_link_paths ? scheme_false : scheme_true));
 
@@ -371,6 +376,13 @@ void scheme_set_compiled_file_paths(Scheme_Object *list)
   initial_compiled_file_paths = list;
 }
 
+void scheme_set_compiled_file_roots(Scheme_Object *list)
+{
+  if (!initial_compiled_file_roots)
+    REGISTER_SO(initial_compiled_file_roots);
+  initial_compiled_file_roots = list;
+}
+
 /*========================================================================*/
 /*                              port records                              */
 /*========================================================================*/

src/racket/src/schminc.h

@@ -12,9 +12,9 @@
    finally, set EXPECTED_PRIM_COUNT to the right value and
    USE_COMPILED_STARTUP to 1 and `make' again. */
 
-#define USE_COMPILED_STARTUP 0
+#define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1072
+#define EXPECTED_PRIM_COUNT 1073
 #define EXPECTED_UNSAFE_COUNT 79
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_FUTURES_COUNT 15

src/racket/src/schpriv.h

@@ -3767,6 +3767,7 @@ Scheme_Object *scheme_symbol_to_string(Scheme_Object *sym);
 #define SCHEME_SYM_WEIRDP(o) (MZ_OPT_HASH_KEY(&((Scheme_Symbol *)(o))->iso) & 0x3)
 
 Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_compiled_file_roots(int argc, Scheme_Object *argv[]);
 
 #ifdef MZ_USE_JIT
 int scheme_can_inline_fp_op();

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.3.0.23"
+#define MZSCHEME_VERSION "5.3.0.24"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 3
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 23
+#define MZSCHEME_VERSION_W 24
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

src/racket/src/startup.inc

@@ -138,6 +138,7 @@
 " normal-case-path"
 " path-replace-suffix"
 " path-add-suffix"
+" reroot-path"
 " find-col-file"
 " collection-path"
 " collection-file-path"
@@ -178,6 +179,56 @@
 " 'windows)))))"
 "((string? s)(string->path s))"
 "(else s))))"
+"(define-values(reroot-path)"
+"(lambda(p root)"
+"(unless(or(path-string? p)(path-for-some-system? p))"
+" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 0 p root))"
+"(unless(or(path-string? root)(path-for-some-system? root))"
+" (raise-argument-error 'reroot-path \"(or/c path-string? path-for-some-system?)\" 1 p root))"
+"(define conv(if(path-for-some-system? p)"
+"(path-convention-type p)"
+"(system-path-convention-type)))"
+"(unless(or(complete-path? p)"
+"(eq?(system-path-convention-type) conv))"
+"(raise-arguments-error 'reroot-path"
+" \"path is not complete and not the platform's convention\""
+" \"path\" p"
+" \"platform convention type\" (system-path-convention-type)))"
+"(unless(eq?(if(path-for-some-system? root)"
+"(path-convention-type root)"
+"(system-path-convention-type))"
+" conv)"
+"(raise-arguments-error 'reroot-path"
+" \"given paths use different conventions\""
+" \"path\" p"
+" \"root path\" root))"
+"(define c-p(normal-case-path(cleanse-path(if(complete-path? p)"
+" p"
+"(path->complete-path p)))))"
+"(define bstr(path->bytes c-p))"
+"(cond "
+"((eq? conv 'unix) "
+" (if (bytes=? bstr #\"/\")"
+"(if(path? root)"
+" root"
+"(string->path root))"
+"(build-path root(bytes->path(subbytes(path->bytes c-p) 1) conv))))"
+"((eq? conv 'windows)"
+"(build-path"
+" root"
+"(bytes->path"
+"(cond"
+" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\[a-z]:\" bstr)"
+" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4 5) #\"\\\\\" (subbytes bstr 6)))"
+" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)"
+" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))"
+" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\[?]\\\\\\\\UNC\\\\\\\\\" bstr)"
+" (bytes-append #\"\\\\\\\\?\\\\REL\\\\\" (subbytes bstr 4)))"
+" ((regexp-match? #rx\"^\\\\\\\\\\\\\\\\\" bstr)"
+" (bytes-append #\"UNC\\\\\" (subbytes bstr 2)))"
+" ((regexp-match? #rx\"^[a-z]:\" bstr)"
+"(bytes-append(subbytes bstr 0 1)(subbytes bstr 2))))"
+" conv))))))"
 "(define-values(find-executable-path)"
 "(case-lambda "
 "((program libpath reverse?)"
@@ -657,16 +708,18 @@
 "(date-of-1(lambda(a)"
 "(let((v(file-or-directory-modify-seconds a #f(lambda() #f))))"
 "(and v(cons a v)))))"
-"(date-of(lambda(a modes)"
+"(date-of(lambda(a modes roots)"
+"(ormap(lambda(root-dir)"
 "(ormap"
 "(lambda(compiled-dir)"
-"(let((a(a compiled-dir)))"
+"(let((a(a root-dir compiled-dir)))"
 "(date-of-1 a)))"
-" modes)))"
+" modes))"
+" roots)))"
 "(date>=?"
-"(lambda(modes a bm)"
+"(lambda(modes roots a bm)"
 "(and a"
-"(let((am(date-of a modes)))"
+"(let((am(date-of a modes roots)))"
 "(or(and(not bm) am) "
 "(and am bm(>=(cdr am)(cdr bm)) am))))))"
 "(with-dir*(lambda(base t) "
@@ -717,15 +770,21 @@
 " orig-path"
 "(build-path base alt-file))))"
 "((base)(if(eq? base 'relative) 'same base))"
-"((modes)(use-compiled-file-paths)))"
+"((modes)(use-compiled-file-paths))"
+"((roots)(current-compiled-file-roots))"
+"((reroot)(lambda(p d)"
+"(cond"
+"((eq? d 'same) p)"
+"((relative-path? d)(build-path p d))"
+"(else(reroot-path p d))))))"
 "(let*((main-path-d(date-of-1 path))"
 "(alt-path-d(and alt-path "
 "(not main-path-d)"
 "(date-of-1 alt-path)))"
 "(path-d(or main-path-d alt-path-d))"
 "(get-so(lambda(file rep-sfx?)"
-"(lambda(compiled-dir)"
-"(build-path base"
+"(lambda(root-dir compiled-dir)"
+"(build-path(reroot base root-dir)"
 " compiled-dir"
 " \"native\""
 "(system-library-subpath)"
@@ -734,12 +793,12 @@
 " file"
 " dll-suffix)"
 " file)))))"
-"(zo(lambda(compiled-dir)"
-"(build-path base"
+"(zo(lambda(root-dir compiled-dir)"
+"(build-path(reroot base root-dir)"
 " compiled-dir"
 " (path-add-suffix file #\".zo\"))))"
-"(alt-zo(lambda(compiled-dir)"
-"(build-path base"
+"(alt-zo(lambda(root-dir compiled-dir)"
+"(build-path(reroot base root-dir)"
 " compiled-dir"
 " (path-add-suffix alt-file #\".zo\"))))"
 "(so(get-so file #t))"
@@ -749,23 +808,23 @@
 "(with-dir(lambda(t)(with-dir* base t))))"
 "(cond"
 "((and try-main?"
-"(date>=? modes so path-d))"
+"(date>=? modes roots so path-d))"
 " =>(lambda(so-d)"
 "(parameterize((current-module-declare-source #f))"
 "(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))"
 "((and try-alt?"
-"(date>=? modes alt-so alt-path-d))"
+"(date>=? modes roots alt-so alt-path-d))"
 " =>(lambda(so-d)"
 "(parameterize((current-module-declare-source alt-path))"
 "(with-dir(lambda()((current-load-extension)(car so-d) expect-module))))))"
 "((and try-main?"
-"(date>=? modes zo path-d))"
+"(date>=? modes roots zo path-d))"
 " =>(lambda(zo-d)"
 "(register-zo-path name ns-hts(car zo-d) #f base)"
 "(parameterize((current-module-declare-source #f))"
 "(with-dir(lambda()((current-load)(car zo-d) expect-module))))))"
 "((and try-alt?"
-"(date>=? modes alt-zo path-d))"
+"(date>=? modes roots alt-zo path-d))"
 " =>(lambda(zo-d)"
 "(register-zo-path name ns-hts(car zo-d) alt-path base)"
 "(parameterize((current-module-declare-source alt-path))"

src/racket/src/startup.rktl

@@ -185,6 +185,7 @@
              normal-case-path
              path-replace-suffix
              path-add-suffix
+             reroot-path
              find-col-file
              collection-path
              collection-file-path
@@ -230,6 +231,57 @@
        [(string? s) (string->path s)]
        [else s])))
 
+  (define-values (reroot-path)
+    (lambda (p root)
+      (unless (or (path-string? p) (path-for-some-system? p))
+        (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 0 p root))
+      (unless (or (path-string? root) (path-for-some-system? root))
+        (raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 1 p root))
+      (define conv (if (path-for-some-system? p)
+                       (path-convention-type p)
+                       (system-path-convention-type)))
+      (unless (or (complete-path? p)
+                  (eq? (system-path-convention-type) conv))
+        (raise-arguments-error 'reroot-path
+                               "path is not complete and not the platform's convention"
+                               "path" p
+                               "platform convention type" (system-path-convention-type)))
+      (unless (eq? (if (path-for-some-system? root)
+                       (path-convention-type root)
+                       (system-path-convention-type))
+                   conv)
+        (raise-arguments-error 'reroot-path
+                               "given paths use different conventions"
+                               "path" p
+                               "root path" root))
+      (define c-p (normal-case-path (cleanse-path (if (complete-path? p)
+                                                      p
+                                                      (path->complete-path p)))))
+      (define bstr (path->bytes c-p))
+      (cond 
+       [(eq? conv 'unix) 
+        (if (bytes=? bstr #"/")
+            (if (path? root)
+                root
+                (string->path root))
+            (build-path root (bytes->path (subbytes (path->bytes c-p) 1) conv)))]
+       [(eq? conv 'windows)
+        (build-path
+         root
+         (bytes->path
+          (cond
+           ((regexp-match? #rx"^\\\\\\\\[?]\\\\[a-z]:" bstr)
+            (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4 5) #"\\" (subbytes bstr 6)))
+           ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
+            (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
+           ((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
+            (bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
+           ((regexp-match? #rx"^\\\\\\\\" bstr)
+            (bytes-append #"UNC\\" (subbytes bstr 2)))
+           ((regexp-match? #rx"^[a-z]:" bstr)
+            (bytes-append (subbytes bstr 0 1) (subbytes bstr 2))))
+          conv))])))
+
   ;; ------------------------------ executable path ------------------------------
 
   (define-values (find-executable-path)
@@ -756,7 +808,7 @@
 
   (define-values (dll-suffix)
     (system-type 'so-suffix))
-
+       
   (define-values (default-load/use-compiled)
     (let* ([resolve (lambda (s)
                       (if (complete-path? s)
@@ -766,16 +818,18 @@
            [date-of-1 (lambda (a)
                         (let ([v (file-or-directory-modify-seconds a #f (lambda () #f))])
                           (and v (cons a v))))]
-           [date-of (lambda (a modes)
-                      (ormap
-                       (lambda (compiled-dir)
-                         (let ([a (a compiled-dir)])
-                           (date-of-1 a)))
-                       modes))]
+           [date-of (lambda (a modes roots)
+                      (ormap (lambda (root-dir)
+                               (ormap
+                                (lambda (compiled-dir)
+                                  (let ([a (a root-dir compiled-dir)])
+                                    (date-of-1 a)))
+                                modes))
+                             roots))]
            [date>=?
-            (lambda (modes a bm)
+            (lambda (modes roots a bm)
               (and a
-                   (let ([am (date-of a modes)])
+                   (let ([am (date-of a modes roots)])
                      (or (and (not bm) am) 
                          (and am bm (>= (cdr am) (cdr bm)) am)))))]
            [with-dir* (lambda (base t) 
@@ -830,15 +884,21 @@
                                                orig-path
                                                (build-path base alt-file)))]
                           [(base) (if (eq? base 'relative) 'same base)]
-                          [(modes) (use-compiled-file-paths)])
+                          [(modes) (use-compiled-file-paths)]
+                          [(roots) (current-compiled-file-roots)]
+                          [(reroot) (lambda (p d)
+                                      (cond
+                                       [(eq? d 'same) p]
+                                       [(relative-path? d) (build-path p d)]
+                                       [else (reroot-path p d)]))])
               (let* ([main-path-d (date-of-1 path)]
                      [alt-path-d (and alt-path 
                                       (not main-path-d)
                                       (date-of-1 alt-path))]
                      [path-d (or main-path-d alt-path-d)]
                      [get-so (lambda (file rep-sfx?)
-                               (lambda (compiled-dir)
-                                 (build-path base
+                               (lambda (root-dir compiled-dir)
+                                 (build-path (reroot base root-dir)
                                              compiled-dir
                                              "native"
                                              (system-library-subpath)
@@ -847,12 +907,12 @@
                                                   file
                                                   dll-suffix)
                                                  file))))]
-                     [zo (lambda (compiled-dir)
-                           (build-path base
+                     [zo (lambda (root-dir compiled-dir)
+                           (build-path (reroot base root-dir)
                                        compiled-dir
                                        (path-add-suffix file #".zo")))]
-                     [alt-zo (lambda (compiled-dir)
-                               (build-path base
+                     [alt-zo (lambda (root-dir compiled-dir)
+                               (build-path (reroot base root-dir)
                                            compiled-dir
                                            (path-add-suffix alt-file #".zo")))]
                      [so (get-so file #t)]
@@ -862,23 +922,23 @@
                      [with-dir (lambda (t) (with-dir* base t))])
                 (cond
                  [(and try-main?
-                       (date>=? modes so path-d))
+                       (date>=? modes roots so path-d))
                   => (lambda (so-d)
                        (parameterize ([current-module-declare-source #f])
                          (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))]
                  [(and try-alt?
-                       (date>=? modes alt-so alt-path-d))
+                       (date>=? modes roots alt-so alt-path-d))
                   => (lambda (so-d)
                        (parameterize ([current-module-declare-source alt-path])
                          (with-dir (lambda () ((current-load-extension) (car so-d) expect-module)))))]
                  [(and try-main?
-                       (date>=? modes zo path-d))
+                       (date>=? modes roots zo path-d))
                   => (lambda (zo-d)
                        (register-zo-path name ns-hts (car zo-d) #f base)
                        (parameterize ([current-module-declare-source #f])
                          (with-dir (lambda () ((current-load) (car zo-d) expect-module)))))]
                  [(and try-alt?
-                       (date>=? modes alt-zo path-d))
+                       (date>=? modes roots alt-zo path-d))
                   => (lambda (zo-d)
                        (register-zo-path name ns-hts (car zo-d) alt-path base)
                        (parameterize ([current-module-declare-source alt-path])