compiler/compilation-path: added

Provides functions for finding the bytecode path for a source file,
which might depend on PLTCOMPILEDROOTS, etc.

pkgs/racket-pkgs/racket-doc/scribblings/raco/make.scrbl

@@ -587,6 +587,46 @@ See also @racket[managed-compile-zo].}
 
 @; ----------------------------------------------------------------------
 
+@section[#:tag "api:compile-path"]{API for Bytecode Paths}
+
+@defmodule[compiler/compilation-path]
+
+@history[#:added "6.0.1.10"]
+
+@defproc[(get-compilation-dir+name [path path-string?]
+                                   [#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
+                                   [#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
+         (values path? path?)]{
+
+Determines the directory that holds the bytecode form of @racket[path]
+plus base name of @racket[path].
+
+The directory is determined by checking @racket[roots] in order, and
+for each element of @racket[roots] checking @racket[modes] in order.
+The first such directory that contains a file whose name matches
+@racket[path] with @filepath{.zo} added (in the sense of
+@racket[path-add-suffix]) is reported as the return directory path.
+If no such file is found, the result corresponds to the first elements
+of @racket[modes] and @racket[roots].}
+
+@defproc[(get-compilation-dir [path path-string?]
+                              [#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
+                              [#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
+         path?]{
+
+The same as @racket[get-compilation-dir+home], but returning only the first result.}
+
+@defproc[(get-compilation-bytecode-file [path path-string?]
+                                        [#:modes modes (non-empty-listof (and/c path-string? relative-path?)) (use-compiled-file-paths)]
+                                        [#:roots roots (non-empty-listof (or/c path-string? 'same)) (current-compiled-file-roots)])
+         path?]{
+
+The same as @racket[get-compilation-dir+home], but combines the
+results and adds a @filepath{.zo} suffix to arrive at a bytecode file
+path.}
+
+@; ----------------------------------------------------------------------
+
 @section[#:tag "zo"]{Compiling to Raw Bytecode}
 
 The @DFlag{no-deps} mode for @exec{raco make} is an improverished

pkgs/racket-pkgs/racket-doc/scribblings/reference/eval.scrbl

@@ -258,7 +258,9 @@ The check for a compiled file occurs whenever the given path
 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
+and the latter provides subdirectories.
+@margin-note*{See also @racketmodname[compiler/compilation-path].}
+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

racket/collects/compiler/cm.rkt

@@ -9,7 +9,8 @@
          racket/promise
          openssl/sha1
          racket/place
-         setup/collects)
+         setup/collects
+         compiler/compilation-path)
 
 (provide make-compilation-manager-load/use-compiled-handler
          managed-compile-zo
@@ -172,47 +173,10 @@
         (loop subcode ht))))
   (for/list ([k (in-hash-keys ht)]) k))
 
-(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 roots path)
-  (let-values ([(dir name) (get-compilation-dir+name mode roots path)])
+  (let-values ([(dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots)])
     (build-path dir name)))
 
-(define (get-compilation-dir mode roots path)
-  (let-values ([(dir name) (get-compilation-dir+name mode roots path)])
-    dir))
-
 (define (touch path)
   (with-compiler-security-guard
    (file-or-directory-modify-seconds 
@@ -420,7 +384,7 @@
                        (lambda (a b) #f) ; extension handler
                        #:source-reader read-src-syntax)))
   (define dest-roots (list (car roots)))
-  (define code-dir (get-compilation-dir mode dest-roots path))
+  (define code-dir (get-compilation-dir path #:modes (list mode) #:roots dest-roots))
 
   ;; Wait for accomplice logging to finish:
   (log-message accomplice-logger 'info "stop" done-key)
@@ -581,7 +545,7 @@
        (trace-printf "end compile: ~a" actual-path)))))
 
 (define (get-compiled-time mode roots path)
-  (define-values (dir name) (get-compilation-dir+name mode roots path))
+  (define-values (dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots))
   (or (try-file-time (build-path dir "native" (system-library-subpath)
                                  (path-add-suffix name (system-type
                                                         'so-suffix))))
@@ -597,7 +561,7 @@
           (call-with-input-file* dep-path (lambda (p) (cdadr (read p))))))))))
 
 (define (get-compiled-sha1 mode roots path)
-  (define-values (dir name) (get-compilation-dir+name mode roots path))
+  (define-values (dir name) (get-compilation-dir+name path #:modes (list mode) #:roots roots))
   (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

racket/collects/compiler/compilation-path.rkt

@@ -0,0 +1,77 @@
+#lang racket/base
+
+(provide get-compilation-dir+name
+         get-compilation-dir
+         get-compilation-bytecode-file)
+
+(define (do-get-compilation-dir+name who path modes roots)
+  ;; Check arguments
+  (unless (path-string? path)
+    (raise-argument-error who "path-string?" path))
+  (unless (and (list? modes)
+               (pair? modes)
+               (andmap (lambda (p)
+                         (and (path-string? p)
+                              (relative-path? p)))
+                       modes))
+    (raise-argument-error who "(non-empty-listof (and/c path-string? relative-path?))" modes))
+  (unless (and (list? roots)
+               (pair? roots)
+               (andmap (lambda (p)
+                         (or (path-string? p) (eq? p 'same)))
+                       roots))
+    (raise-argument-error who "(non-empty-listof (or/c path-string? 'same))" roots))
+  ;; Function to try one combination:
+  (define (get-one mode 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 modes) (car roots)))
+  (if (or (and (null? (cdr roots))
+               (null? (cdr modes)))
+          (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 mode + root:
+          (values p n)]
+         [else
+          ;; Check next root:
+          (let mloop ([modes modes])
+            (cond
+             [(null? modes) (loop (cdr roots))]
+             [else
+              (define-values (p n) (get-one (car modes) (car roots)))
+              (if (file-exists? (path-add-suffix (build-path p n) #".zo"))
+                  (values p n)
+                  (mloop (cdr modes)))]))]))))
+
+(define (get-compilation-dir+name path 
+                                  #:modes [modes (use-compiled-file-paths)]
+                                  #:roots [roots (current-compiled-file-roots)])
+  (do-get-compilation-dir+name 'get-compilation-dir+name path modes roots))
+  
+(define (get-compilation-dir path 
+                             #:modes [modes (use-compiled-file-paths)]
+                             #:roots [roots (current-compiled-file-roots)])
+  (let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-dir path modes roots)])
+    dir))
+
+(define (get-compilation-bytecode-file path 
+                                       #:modes [modes (use-compiled-file-paths)]
+                                       #:roots [roots (current-compiled-file-roots)])
+  (let-values ([(dir name) (do-get-compilation-dir+name 'get-compilation-bytecode-file path modes roots)])
+    (build-path dir (path-add-suffix name #".zo"))))