serialize srclocs in bytecode; change expander to keep srclocs

To avoid recording absolute paths from a build environment in bytecode
files, the bytecode writer converts paths to relative form based on
`current-write-relative-directory`. For paths that cannot be made
relative in that way and that are in source locations in syntax
objects, the printer in v6.x converted those paths to strings that
drop most of the path.

The v7 expander serializes syntax objects as part of `compile` instead
of `write`, so it can't truncate paths in the traditional way. To help
out the expander, the core `write` function for compiled code now
allows `srcloc` values --- as long as the source field is a path,
string, byte string, symbol, or #f. (Constraining the source field
avoids various problems, including problems that could be created by
cyclic values.) As the core `write` for compiled code prints a path,
it truncates a source path in the traditional way.

The expander doesn't constrain source locations in syntax objects to
have path, string, etc., source values. It can serialize syntax
objects with non-path source values at `compile` time, so there's no
loss of functionality.

The end result is to fix abolute paths that were getting stored in the
bytecode for compiled packages, since that's no good for installing
packages in built form (which happens, for example, during a
distribution build).

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.0.0.5")
+(define version "7.0.0.6")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

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

@@ -988,7 +988,10 @@ The fields of a @racket[srcloc] instance are as follows:
  @item{@racket[span] --- The number of covered positions (counts from
  0) or @racket[#f] (unknown).}
 
-]}
+]
+
+See @secref["print-compiled"] for information about the treatment of
+@racket[srcloc] values that are embedded in compiled code.}
 
 
 @defproc[(srcloc->string [srcloc srcloc?]) (or/c string? #f)]{

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

@@ -26,8 +26,9 @@ output port or returning the byte string otherwise. The
 @racket[s-exp->fasl].
 
 The @racket[v] argument must be a value that could be @racket[quote]d
-as a literal---that is, something for which @racket[(compile `(quote
+as a literal---that is, a value without syntax objects for which
-,v))] would work and be @racket[read]able after @racket[write]. The
+@racket[(compile `(quote ,v))]
+would work and be @racket[read]able after @racket[write]. The
 byte string produced by @racket[s-exp->fasl] does not use the same
 format as compiled code, however.
 
@@ -38,7 +39,9 @@ preserve graph structure, handle cyclic data, and encode serializable
 structures. The @racket[s-exp->fasl] and @racket[fasl->s-exp]
 functions consult @racket[current-write-relative-directory] and
 @racket[current-load-relative-directory], respectively, in the same
-way as bytecode saving and loading to store paths in relative form.
+way as bytecode saving and loading to store paths in relative form,
+and they similarly allow and convert constrained @racket[srcloc]
+values (see @secref["print-compiled"]).
 
 Unless @racket[keep-mutable?] is provided as true to
 @racket[s-exp->fasl], then mutable values in @racket[v] are replaced

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

@@ -555,11 +555,6 @@ assembly code for Racket, and reading such a form produces a compiled
 form when the @racket[read-accept-compiled] parameter is set to
 @racket[#t].
 
-When a compiled form contains syntax object constants, they must not
-be @tech{tainted} or @tech{armed}; the @litchar{#~}-marshaled form
-drops source-location information and properties (see
-@secref["stxprops"]) for the @tech{syntax objects}.
-
 Compiled code parsed from @litchar{#~} is marked as non-runnable if
 the current code inspector (see @racket[current-code-inspector]) is
 not the original code inspector; on attempting to evaluate or reoptimize
@@ -593,7 +588,7 @@ identifier; those functions lead to top-level and module variables
 with @tech{unreadable symbol}ic names, and the names are deterministic
 as long as expansion is otherwise deterministic.
 
-Finally, a compiled form may contain path literals. Although paths are
+A compiled form may contain path literals. Although paths are
 not normally printed in a way that can be read back in, path literals
 can be written and read as part of compiled code. The
 @racket[current-write-relative-directory] parameter is used to convert
@@ -610,6 +605,19 @@ coerced to a string that preserves only part of the path (an in effort
 to make it less tied to the build-time filesystem, which can be
 different than the run-time filesystem).
 
+Finally, a compiled form may contain @racket[srcloc] structures if the
+source field of the structure is a path for some system, a string, a
+byte string, a symbol, or @racket[#f]. For a path value (matching the
+current platform's convention), if the path cannot be recorded as a
+relative path based on @racket[current-write-relative-directory], then
+it is converted to a string with at most two path elements; if the
+path contains more than two elements, then the string contains
+@litchar{.../}, the next-to-last element, @litchar{/} and the last
+element. The intent of the constraints on @racket[srcloc] values and
+the conversion of the source field is to preserve some source
+information but not expose or record a path that makes no sense on
+a different filesystem or platform.
+
 For internal testing purposes, when the
 @as-index{@envvar{PLT_VALIDATE_LOAD}} environment variable is set, the
 reader runs a validator on bytecode parsed from @litchar{#~}. The
@@ -623,4 +631,6 @@ procedure is called.
                                     mark the loaded code as generally
                                     unrunnable instead of rejecting at
                                     read time references to unsafe
-                                    operations.}]
+                                    operations.}
+        #:changed "7.0" @elem{Allowed some @racket[srcloc] values
+                              embedded in compiled code.}]

pkgs/racket-test-core/tests/racket/fasl.rktl

@@ -27,11 +27,12 @@
       43/100
       44+100i
       45.0+100.0i
-      46f0))
+      46f0
+      (srcloc "x" 1 2 3 4)))
 
 ;; The fasl format is meant to be forward-compatible:
 (define immutables-regression-bstr
-  #"racket/fasl:\0\200\371\0\34\"n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\200\16\bnineteen\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\n\0\08B")
+  #"racket/fasl:\0\200\n\1\34#n\4\3\6\ao\r2\16\5three\23\4four\25\4five\21\3six\"u \3vwx\36yz\35\2{|\16\afifteen%\1\2\200\16\bnineteen\16\asixteen\177%\0\2\202\23\ntwenty-one\204\23\ftwenty-three%\2\2\206\207\210\211#\16\ftwenty-eight\3\213\214\23\00231\b\340\b\200\344\f\b\201\320\204\0\0\b\2010W\5\0\b\201\200\3566\0\b\201\200\300\r\26\b\202\0\374\371\330\b\0\0\0\b\202\0`v\363\263b\1\0\b\202\0\0\220\235\316\332\2027\t\0\0\0\0\0\200D@\t\315\314\314\314\314\314\20@\v\231\322\f\232\322\f\t\0\0\0\0\0\200F@\t\0\0\0\0\0\0Y@\n\0\08B\34\6\16\6srcloc\23\1xopqr")
 
 (for ([i (in-list immutables)])
   (test i fasl->s-exp (s-exp->fasl i)))
@@ -89,16 +90,27 @@
   (let ([unix-path (bytes->path #"here" 'unix)]
         [windows-path (bytes->path #"there" 'windows)])
     (test unix-path fasl->s-exp (s-exp->fasl unix-path))
-    (test windows-path fasl->s-exp (s-exp->fasl windows-path))))
+    (test windows-path fasl->s-exp (s-exp->fasl windows-path))
+    (if (eq? (system-path-convention-type) 'unix)
+        (test (srcloc "here" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc unix-path 1 2 3 4)))
+        (test (srcloc "there" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc windows-path 1 2 3 4))))
+    (let ([root (car (filesystem-root-list))])
+      (test (srcloc (path->string root) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc root 1 2 3 4)))
+      (test (srcloc (path->string (build-path root "x")) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path root "x") 1 2 3 4))))
+    (test (srcloc ".../a/b" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path (current-directory) "a" "b") 1 2 3 4)))))
 
 (let* ([rel-p (build-path "nested" "data.rktd")]
        [p (build-path (current-directory) rel-p)])
-  (define bstr
+  (define-values (bstr srcloc-bstr)
     (parameterize ([current-write-relative-directory (current-directory)])
-      (s-exp->fasl p)))
+      (values
+       (s-exp->fasl p)
+       (s-exp->fasl (srcloc p 10 20 30 40)))))
   (parameterize ([current-load-relative-directory #f])
-    (test rel-p fasl->s-exp bstr))
+    (test rel-p fasl->s-exp bstr)
+    (test (srcloc rel-p 10 20 30 40) fasl->s-exp srcloc-bstr))
   (parameterize ([current-load-relative-directory (current-directory)])
-    (test p fasl->s-exp bstr)))
+    (test p fasl->s-exp bstr)
+    (test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr)))
 
 (report-errs)

pkgs/racket-test-core/tests/racket/print.rktl

@@ -339,6 +339,35 @@
   (write (s) (p o))
   (test "ok" get-output-string o))
 
+;; ----------------------------------------
+;; Check that some values are allowed in a srcloc source
+;; in printed compiled code, and some values are not
+
+(let ()
+  (define (try v [result-v v] #:ok? [ok? #t])
+    (define-values (i o) (make-pipe))
+    (define c (compile `,(srcloc v 1 2 3 4)))
+    (cond
+     [ok?
+      (write c o)
+      (test result-v
+            srcloc-source
+            (parameterize ([current-load-relative-directory (build-path (current-directory) "sub")])
+              (eval (parameterize ([read-accept-compiled #t])
+                      (read i)))))]
+     [else
+      (err/rt-test (write c o) (lambda (exn) (and (exn:fail? exn)
+                                                  (regexp-match? #rx"cannot marshal" (exn-message exn)))))]))
+
+  (try #f)
+  (try 'apple)
+  (try "apple")
+  (try #"apple")
+  (try (string->path "apple") "apple")
+
+  (try 7 #:ok? #f)
+  (try (box 7) #:ok? #f))
+
 ;; ----------------------------------------
 
 (report-errs)

pkgs/racket-test-core/tests/racket/stx.rktl

@@ -2600,6 +2600,23 @@
                 #rx"key for a perserved property must be an interned symbol"
                 (exn-message exn))))
 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Make sure that paths from the current installation are not
+;; preserved in marshaled bytecode
+
+(let ([m '(module m racket/base
+            ;; Extending a primitive structure type tends to
+            ;; capture an identifier whose source is "kernstruct.rkt"
+            (define-struct (cookie-error exn:fail) ()))])
+  (define o (open-output-bytes))
+  (write (compile m) o)
+  (call-with-output-file "/tmp/d" #:exists 'replace (lambda (o) (write (compile m) o)))
+  (test #t
+        not
+        (regexp-match? (regexp-quote
+                        (path->bytes (collection-file-path "kernstruct.rkt" "racket/private")))
+                       (get-output-bytes o))))
+
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Make sure the srcloc encoding doesn't do something strange
 ;; with a path in a root directory:
@@ -2615,7 +2632,7 @@
     (write (compile (read-syntax path p)) out)
     (eval (read in))
     (define src (syntax-source ((dynamic-require path 'f))))
-    (test path values src)))
+    (test (path->string path) values src)))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

pkgs/zo-lib/compiler/zo-marshal.rkt

@@ -11,7 +11,8 @@
          racket/pretty
          racket/path
          racket/set
-         racket/extflonum)
+         racket/extflonum
+         racket/private/truncate-path)
 
 (provide/contract
  [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)]
@@ -329,9 +330,10 @@
   CPT_SET_BANG
   CPT_VARREF
   CPT_APPLY_VALUES
-  CPT_OTHER_FORM)
+  CPT_OTHER_FORM
+  CPT_SRCLOC)
 
-(define CPT_SMALL_NUMBER_START 46)
+(define CPT_SMALL_NUMBER_START 47)
 (define CPT_SMALL_NUMBER_END 74)
 
 (define CPT_SMALL_SYMBOL_START 74)
@@ -745,26 +747,8 @@
           (out-anything qv out))]
        [(? path?)
         (out-byte CPT_PATH out)
-        (define (within? p)
-          (and (relative-path? p)
-               (let loop ([p p])
-                 (define-values (base name dir?) (split-path p))
-                 (and (not (eq? name 'up))
-                      (not (eq? name 'same))
-                      (or (not (path? base))
-                          (loop base))))))
         (define maybe-rel
-          (and (current-write-relative-directory)
+          (path->relative-path v))
-               (let ([dir (current-write-relative-directory)])
-                 (and (or (not dir)
-                          (within? (find-relative-path v
-                                                       (if (pair? dir)
-                                                           (cdr dir)
-                                                           dir))))
-                      (find-relative-path v
-                                          (if (pair? dir)
-                                              (car dir)
-                                              dir))))))
         (cond
          [(not maybe-rel)
           (define bstr (path->bytes v))
@@ -777,6 +761,19 @@
                               (path-element->bytes e)
                               e))
                         out)])]
+       [(? srcloc?)
+        (out-byte CPT_SRCLOC out)
+        (define src (srcloc-source v))
+        (define new-src
+          (cond
+            [(and (path? src) (not (path->relative-path src)))
+             (truncate-path src)]
+            [else src]))
+        (out-anything new-src out)
+        (out-anything (srcloc-line v) out)
+        (out-anything (srcloc-column v) out)
+        (out-anything (srcloc-position v) out)
+        (out-anything (srcloc-span v) out)]
        [(or (? regexp?)
             (? byte-regexp?)
             (? number?)
@@ -973,3 +970,24 @@
    [(struct-other-shape? constantness)
     (to-sym 5)]
    [else #f]))
+
+(define (path->relative-path v)
+  (define (within? p)
+    (and (relative-path? p)
+         (let loop ([p p])
+           (define-values (base name dir?) (split-path p))
+           (and (not (eq? name 'up))
+                (not (eq? name 'same))
+                (or (not (path? base))
+                    (loop base))))))
+  (and (current-write-relative-directory)
+       (let ([dir (current-write-relative-directory)])
+         (and (or (not dir)
+                  (within? (find-relative-path v
+                                               (if (pair? dir)
+                                                   (cdr dir)
+                                                   dir))))
+              (find-relative-path v
+                                  (if (pair? dir)
+                                      (car dir)
+                                      dir))))))

pkgs/zo-lib/compiler/zo-parse.rkt

@@ -294,7 +294,8 @@
     [43 varref]
     [44 apply-values]
     [45 other-form]
-    [46 74 small-number]
+    [46 srcloc]
+    [47 74 small-number]
     [74 92 small-symbol]
     [92 ,(+ 92 small-list-max) small-proper-list]
     [,(+ 92 small-list-max) 192 small-list]
@@ -460,6 +461,12 @@
                    (build-path p (if (bytes? e) (bytes->path-element e) e))))
                ;; Read a path:
                (bytes->path (read-compact-bytes cp len))))]
+        [(srcloc)
+         (srcloc (read-compact cp)
+                 (read-compact cp)
+                 (read-compact cp)
+                 (read-compact cp)
+                 (read-compact cp))]
         [(small-number)
          (let ([l (- ch cpt-start)])
            l)]

racket/collects/racket/fasl.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
-(require (for-syntax racket/base))
+(require (for-syntax racket/base)
+         "private/truncate-path.rkt")
 
 (provide s-exp->fasl
          fasl->s-exp)
@@ -76,6 +77,8 @@
   (fasl-hash-type     36)
   (fasl-immutable-hash-type 37)
 
+  (fasl-srcloc 38)
+
   ;; Unallocated numbers here are for future extensions
 
   ;; 100 to 255 is used for small integers:
@@ -124,6 +127,18 @@
        (loop (struct->vector v))]
       [else (void)]))
   (define exploded-wrt-dir 'not-ready)
+  (define (path->relative-path-elements v)
+    (when (and (eq? exploded-wrt-dir 'not-ready)
+               (path? v))
+      (define wrt-dir (current-write-relative-directory))
+      (set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir))))
+    (and exploded-wrt-dir
+         (path? v)
+         (let ([exploded (explode-path v)])
+           (and (for/and ([wrt-p (in-list exploded-wrt-dir)]
+                          [p (in-list exploded)])
+                  (equal? wrt-p p))
+                (list-tail exploded (length exploded-wrt-dir))))))
   (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
   ;; The fasl formal prefix:
   (write-bytes fasl-prefix o)
@@ -203,18 +218,7 @@
            (write-fasl-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o)
            (write-fasl-bytes v o)]
           [(path-for-some-system? v)
-           (when (and (eq? exploded-wrt-dir 'not-ready)
+           (define rel-elems (path->relative-path-elements v))
-                      (path? v))
-             (define wrt-dir (current-write-relative-directory))
-             (set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir))))
-           (define rel-elems
-             (and exploded-wrt-dir
-                  (path? v)
-                  (let ([exploded (explode-path v)])
-                    (and (for/and ([wrt-p (in-list exploded-wrt-dir)]
-                                   [p (in-list exploded)])
-                           (equal? wrt-p p))
-                         (list-tail exploded (length exploded-wrt-dir))))))
            (cond
              [rel-elems
               (write-byte fasl-relative-path-type o)
@@ -224,6 +228,26 @@
               (write-byte fasl-path-type o)
               (write-fasl-bytes (path->bytes v) o)
               (loop (path-convention-type v))])]
+          [(and (srcloc? v) (let ([src (srcloc-source v)])
+                              (or (not src)
+                                  (path-for-some-system? src)
+                                  (string? src)
+                                  (bytes? src)
+                                  (symbol? src))))
+           (define src (srcloc-source v))
+           (define new-src
+             (cond
+               [(and (path? src)
+                     (not (path->relative-path-elements src)))
+                ;; Convert to a string
+                (truncate-path src)]
+               [else src]))
+           (write-fasl-integer fasl-srcloc o)
+           (loop new-src)
+           (loop (srcloc-line v))
+           (loop (srcloc-column v))
+           (loop (srcloc-position v))
+           (loop (srcloc-span v))]
           [(pair? v)
            (cond
              [(pair? (cdr v))
@@ -414,6 +438,8 @@
       (define len (read-fasl-integer i))
       (for/fold ([ht ht]) ([j (in-range len)])
         (hash-set ht (loop) (loop)))]
+     [(fasl-srcloc)
+      (srcloc (loop) (loop) (loop) (loop) (loop))]
      [else
       (cond
         [(type . >= . fasl-small-integer-start)

racket/collects/racket/private/truncate-path.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+(provide truncate-path)
+
+;; Drop information from the path `p` in the same way as marshaling a
+;; path in a srcloc as part of compiled code
+(define (truncate-path p)
+  (define-values (base1 name1 dir?) (split-path p))
+  (cond
+    [(path? base1)
+     (define-values (base2 name2 dir?) (split-path base1))
+     (cond
+       [(not base2)
+        ;; Path at a root
+        (path->string p)]
+       [else
+        (string-append ".../" (path->string name2) "/" (path->string name1))])]
+    [(eq? base1 'relative)
+     (path->string name1)]
+     [else
+      ;; Path is a root
+      (path->string p)]))

racket/src/expander/compile/serialize.rkt

@@ -51,13 +51,13 @@
 ;; quoted data (that's non-cyclic and with no internal sharing). A few
 ;; special cases enable a more compact representation:
 ;;
-;;  - numbers, booleans, and symbols are represented as themselves
+;;  - numbers, booleans, symbols, and path srclocs are represented
-;;    (i.e., self-quoting, in a sense);
+;;    as themselves (i.e., self-quoting, in a sense);
 ;;
 ;;  - #&<number> is a reference to a mutable or shared value at
 ;;    position <number> in a deserialization array;
 ;;
-;;  - #(<elem> ...) is a `srcloc`
+;;  - #(<elem> ...) is a srcloc whose source is not a path
 ;;
 ;;  - #:inspector and #:bulk-binding-registry refer to
 ;;    instantiation-time values supplied as imported to the
@@ -297,8 +297,9 @@
           (for ([e (in-vector (struct->vector v) 1)])
             (loop e))]
          [(srcloc? v)
-          (for ([e (in-vector (struct->vector v) 1)])
+          (unless (path? (srcloc-source v))
-            (loop e))]
+            (for ([e (in-vector (struct->vector v) 1)])
+              (loop e)))]
          [else
           (void)])
         ;; `v` may already be in `objs`, but to get the order right
@@ -483,12 +484,19 @@
              (ser-push-optional-quote!)
              (ser-push! 'exact v)))]
      [(srcloc? v)
-      (ser-push! 'tag '#:srcloc)
+      (cond
-      (ser-push! (srcloc-source v))
+        [(path? (srcloc-source v))
-      (ser-push! (srcloc-line v))
+         ;; Let core printer handle it --- and truncate the path if it
-      (ser-push! (srcloc-column v))
+         ;; can't be made relative on serialize
-      (ser-push! (srcloc-position v))
+         (ser-push-optional-quote!)
-      (ser-push! (srcloc-span v))]
+         (ser-push! 'exact v)]
+        [else
+         (ser-push! 'tag '#:srcloc)
+         (ser-push! (srcloc-source v))
+         (ser-push! (srcloc-line v))
+         (ser-push! (srcloc-column v))
+         (ser-push! (srcloc-position v))
+         (ser-push! (srcloc-span v))])]
      [else
       (ser-push-optional-quote!)
       (ser-push! 'exact v)]))

racket/src/expander/run/linklet.rkt

@@ -417,6 +417,7 @@
 (struct path-bytes (bstr) #:prefab)
 (struct unreadable (str) #:prefab)
 (struct void-value () #:prefab)
+(struct srcloc-parts (source line column position span) #:prefab)
 
 (define (marshal c)
   (datum-map c (lambda (tail? c)
@@ -424,6 +425,11 @@
                   [(path? c) (path-bytes (path->bytes c))]
                   [(and (symbol? c) (symbol-unreadable? c)) (unreadable (symbol->string c))]
                   [(void? c) (void-value)]
+                  [(srcloc? c) (srcloc-parts (marshal (srcloc-source c))
+                                             (marshal (srcloc-line c))
+                                             (marshal (srcloc-column c))
+                                             (marshal (srcloc-position c))
+                                             (marshal (srcloc-span c)))]
                   [else c]))))
 
 (define (unmarshal c)
@@ -433,6 +439,11 @@
                 [(path-bytes? c) (bytes->path (path-bytes-bstr c))]
                 [(unreadable? c) (string->unreadable-symbol (unreadable-str c))]
                 [(void-value? c) (void)]
+                [(srcloc-parts? c)  (srcloc (marshal (srcloc-parts-source c))
+                                            (marshal (srcloc-parts-line c))
+                                            (marshal (srcloc-parts-column c))
+                                            (marshal (srcloc-parts-position c))
+                                            (marshal (srcloc-parts-span c)))]
                 [else c]))))
 
 ;; Like `correlated->datum`, but preserves 'inferred-name information

racket/src/racket/src/print.c

@@ -154,6 +154,7 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
 				PrintParams *pp, int notdisplay);
 static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp);
 
+static Scheme_Object *srcloc_path_to_string(Scheme_Object *p);
 
 #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1)
 
@@ -2388,6 +2389,52 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
     {
       print_compact(pp, CPT_VOID);
     }
+  else if (compact && SCHEME_CHAPERONE_STRUCTP(obj) && scheme_is_location(obj))
+    {
+      /* Support srclocs in marshaled form with special treatment
+         of paths */
+      int i;
+      Scheme_Object *src, *rel_src, *dir;
+
+      src = scheme_struct_ref(obj, 0);
+      if (SCHEME_PATHP(src)) {
+        /* To make paths portable and to avoid full paths, check
+           whether the path can be made relative, in which case it is
+           turned into a list of byte strings. If not, convert to a
+           string using only the last couple of path elements. */
+        dir = scheme_get_param(scheme_current_config(),
+                               MZCONFIG_WRITE_DIRECTORY);
+        if (SCHEME_TRUEP(dir))
+          rel_src = scheme_extract_relative_to(src, dir, mt->path_cache);
+        else
+          rel_src = src;
+        if (SCHEME_PATHP(rel_src)) {
+          src = scheme_hash_get(mt->path_cache, scheme_box(rel_src));
+          if (!src) {
+            src = srcloc_path_to_string(rel_src);
+            scheme_hash_set(mt->path_cache, scheme_box(rel_src), src);
+          }
+        } else {
+          /* let the printer make it relative when recurring */
+        }
+      } else if (SCHEME_FALSEP(src)
+                 || SCHEME_CHAR_STRINGP(src)
+                 || SCHEME_BYTE_STRINGP(src)
+                 || SCHEME_SYMBOLP(src)
+                 || SCHEME_GENERAL_PATHP(src)) {
+        /* ok */
+      } else {
+        cannot_print(pp, notdisplay, obj, ht, compact);
+      }
+
+      print_compact(pp, CPT_SRCLOC);
+      print(src, notdisplay, compact, ht, mt, pp);
+      for (i = 1; i < 5; i++) {
+        print(scheme_struct_ref(obj, i), notdisplay, compact, ht, mt, pp);
+      }
+
+      closed = 1;
+    }
   else if (SCHEME_CHAPERONE_STRUCTP(obj))
     {
       if (compact && SCHEME_PREFABP(obj)) {
@@ -4258,6 +4305,33 @@ static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht,
     flush_from_byte_port(SCHEME_VEC_ELS(vec)[4], orig_pp);
 }
 
+static Scheme_Object *srcloc_path_to_string(Scheme_Object *p)
+{
+  Scheme_Object *base, *name, *dir_name;
+  int isdir;
+  
+  name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PLATFORM_PATH_KIND);
+  if (SCHEME_PATHP(name) && SCHEME_PATHP(base)) {
+    dir_name = scheme_split_path(SCHEME_PATH_VAL(base), SCHEME_PATH_LEN(base), &base, &isdir, SCHEME_PLATFORM_PATH_KIND);
+    if (SCHEME_FALSEP(base)) {
+      /* Path is file at root, so just keep the whole path */
+      return scheme_path_to_char_string(p);
+    }
+    if (SCHEME_PATHP(dir_name))
+      name = scheme_append_strings(scheme_path_to_char_string(dir_name),
+                                   scheme_append_strings(scheme_make_utf8_string("/"),
+                                                         scheme_path_to_char_string(name)));
+    else
+      name = scheme_path_to_char_string(name);
+    return scheme_append_strings(scheme_make_utf8_string(".../"), name);
+  } else if (SCHEME_PATHP(name))
+    return scheme_path_to_char_string(name);
+  else {
+    /* original path is a root */
+    return scheme_path_to_char_string(p);
+  }
+}
+
 /*========================================================================*/
 /*                       precise GC traversers                            */
 /*========================================================================*/

racket/src/racket/src/read.c

@@ -3308,6 +3308,25 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
         }
       }
       break;
+    case CPT_SRCLOC:
+      {
+        Scheme_Object *r;
+        r = scheme_unsafe_make_location();
+        /* No checking of field values, so a corrupt ".zo" can
+           create bad srclocs (but won't crash while reading) */
+        v = read_compact(port, 0);
+        ((Scheme_Structure *)r)->slots[0] = v;
+        v = read_compact(port, 0);
+        ((Scheme_Structure *)r)->slots[1] = v;
+        v = read_compact(port, 0);
+        ((Scheme_Structure *)r)->slots[2] = v;
+        v = read_compact(port, 0);
+        ((Scheme_Structure *)r)->slots[3] = v;
+        v = read_compact(port, 0);
+        ((Scheme_Structure *)r)->slots[4] = v;
+        return r;
+      }
+      break;
     case CPT_CLOSURE:
       {
         Scheme_Closure *cl;

racket/src/racket/src/schcpt.h

@@ -46,10 +46,11 @@ enum {
   CPT_VARREF,
   CPT_APPLY_VALUES,
   CPT_OTHER_FORM,
+  CPT_SRCLOC,
   _CPT_COUNT_
 };
 
-#define CPT_SMALL_NUMBER_START 46
+#define CPT_SMALL_NUMBER_START 47
 #define CPT_SMALL_NUMBER_END   74
 
 #define CPT_SMALL_SYMBOL_START 74

racket/src/racket/src/schpriv.h

@@ -3790,6 +3790,8 @@ Scheme_Object *scheme_copy_list(Scheme_Object *l);
 
 Scheme_Object *scheme_append_strings(Scheme_Object *s1, Scheme_Object *s2);
 
+Scheme_Object *scheme_unsafe_make_location(void);
+
 void scheme_reset_hash_table(Scheme_Hash_Table *ht, int *history);
 
 XFORM_NONGCING void scheme_set_distinct_eq_hash(Scheme_Object *var2);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "7.0.0.5"
+#define MZSCHEME_VERSION "7.0.0.6"
 
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/startup.inc

@@ -5,6 +5,7 @@ static const char *startup_source =
 "((boot boot)"
 "(1/bound-identifier=? bound-identifier=?)"
 "(1/compile compile)"
+"(compile-keep-source-locations! compile-keep-source-locations!)"
 "(compile-to-linklets compile-to-linklets)"
 "(1/current-compile current-compile)"
 "(1/current-compiled-file-roots current-compiled-file-roots)"
@@ -18298,6 +18299,11 @@ static const char *startup_source =
 "(if(srcloc?"
 " v_95)"
 "(let-values()"
+"(if(path?"
+"(srcloc-source"
+" v_95))"
+"(void)"
+"(let-values()"
 "(begin"
 "(let-values(((v*_2"
 " start*_2"
@@ -18305,7 +18311,7 @@ static const char *startup_source =
 " step*_2)"
 "(normalise-inputs"
 " 'in-vector"
-"                                                                                                                                       \"vector\""
+"                                                                                                                                           \"vector\""
 "(lambda(x_46)"
 "(vector?"
 " x_46))"
@@ -18350,7 +18356,7 @@ static const char *startup_source =
 "(values))))))"
 " for-loop_129)"
 " start*_2)))"
-"(void)))"
+"(void)))))"
 "(let-values()"
 "(void))))))))))"
 "(hash-set!"
@@ -19097,20 +19103,33 @@ static const char *startup_source =
 " c3_0)"
 "(if(srcloc? v_140)"
 "(let-values()"
+"(if(path?"
+"(srcloc-source v_140))"
+"(let-values()"
+"(begin"
+"(ser-push-optional-quote!_0)"
+"(ser-push!_16"
+" 'exact"
+" v_140)))"
+"(let-values()"
 "(begin"
 "(ser-push!_16"
 " 'tag"
 " '#:srcloc)"
 "(ser-push!_16"
-"(srcloc-source v_140))"
+"(srcloc-source"
+" v_140))"
 "(ser-push!_16"
 "(srcloc-line v_140))"
 "(ser-push!_16"
-"(srcloc-column v_140))"
+"(srcloc-column"
+" v_140))"
 "(ser-push!_16"
-"(srcloc-position v_140))"
+"(srcloc-position"
+" v_140))"
 "(ser-push!_16"
-"(srcloc-span v_140))))"
+"(srcloc-span"
+" v_140))))))"
 "(let-values()"
 "(begin"
 "(ser-push-optional-quote!_0)"
@@ -27024,6 +27043,7 @@ static const char *startup_source =
 "(if s_80"
 "(vector(srcloc-source s_80)(srcloc-line s_80)(srcloc-column s_80)(srcloc-position s_80)(srcloc-span s_80))"
 " #f))))"
+"(define-values(keep-source-locations?) #f)"
 "(define-values"
 "(correlate*)"
 "(lambda(stx_15 s-exp_0)"
@@ -27031,9 +27051,9 @@ static const char *startup_source =
 "(define-values(correlate~)(lambda(stx_16 s-exp_1)(begin s-exp_1)))"
 "(define-values"
 "(correlate/app)"
-"(lambda(stx_17 s-exp_2)"
+"(lambda(stx_17 s-exp_2)(begin(if keep-source-locations?(correlate* stx_17 s-exp_2)(correlate~ stx_17 s-exp_2)))))"
-"(begin(if(eq?(system-type 'vm) 'chez-scheme)(correlate* stx_17 s-exp_2)(correlate~ stx_17 s-exp_2)))))"
 "(define-values(->correlated)(lambda(s_2)(begin(datum->correlated s_2 #f))))"
+"(define-values(compile-keep-source-locations!)(lambda(on?_0)(begin(set! keep-source-locations? on?_0))))"
 "(define-values"
 "(compile$2)"
 "(let-values(((compile5_0)"

racket/src/racket/src/struct.c

@@ -5770,6 +5770,20 @@ Scheme_Object *scheme_make_location(Scheme_Object *src,
   return scheme_make_struct_instance(location_struct, 5, a);
 }
 
+Scheme_Object *scheme_unsafe_make_location(void)
+{
+  Scheme_Structure *inst;
+
+  inst = (Scheme_Structure *)scheme_malloc_tagged(STRUCT_BYTES(5));
+  
+  inst->so.type = scheme_structure_type;
+  inst->stype = (Scheme_Struct_Type *)location_struct;
+
+  /* caller must initialize content */
+  
+  return (Scheme_Object *)inst;
+}
+
 int scheme_is_location(Scheme_Object *o)
 {
   if (SCHEME_CHAPERONEP(o))