suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

serialize srclocs in bytecode; change expander to keep srclocs

Browse Source 
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).
This commit is contained in:
Matthew Flatt 2018-06-26 19:28:05 -06:00
parent cda4e5befe
commit b13f723ac6
20 changed files with 373 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

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

5
pkgs/racket-doc/scribblings/reference/exns.scrbl
View File

@ -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)]{

9
pkgs/racket-doc/scribblings/reference/fasl.scrbl
View File

@ -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
,v))] would work and be @racket[read]able after @racket[write]. The
as a literal---that is, a value without syntax objects for which
@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

24
pkgs/racket-doc/scribblings/reference/printer.scrbl
View File

@ -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.}]

26
pkgs/racket-test-core/tests/racket/fasl.rktl
View File

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

29
pkgs/racket-test-core/tests/racket/print.rktl
View File

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

19
pkgs/racket-test-core/tests/racket/stx.rktl
View File

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

62
pkgs/zo-lib/compiler/zo-marshal.rkt
View File

@ -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)
(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))))))
(path->relative-path v))
(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))))))

9
pkgs/zo-lib/compiler/zo-parse.rkt
View File

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

52
racket/collects/racket/fasl.rkt
View File

@ -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)
(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))))))
(define rel-elems (path->relative-path-elements v))
(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)

21
racket/collects/racket/private/truncate-path.rkt Normal file
View File

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

30
racket/src/expander/compile/serialize.rkt
View File

@ -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
;; (i.e., self-quoting, in a sense);
;; - numbers, booleans, symbols, and path srclocs are represented
;; 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)])
(loop e))]
(unless (path? (srcloc-source v))
(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)
(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))]
(cond
[(path? (srcloc-source v))
;; Let core printer handle it --- and truncate the path if it
;; can't be made relative on serialize
(ser-push-optional-quote!)
(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)]))

11
racket/src/expander/run/linklet.rkt
View File

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

74
racket/src/racket/src/print.c
View File

@ -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 */
/*========================================================================*/

19
racket/src/racket/src/read.c
View File

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

3
racket/src/racket/src/schcpt.h
View File

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

2
racket/src/racket/src/schpriv.h
View File

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

4
racket/src/racket/src/schvers.h
View File

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

36
racket/src/racket/src/startup.inc
View File

@ -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)"
"(begin(if(eq?(system-type 'vm) 'chez-scheme)(correlate* stx_17 s-exp_2)(correlate~ 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)))))"
"(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)"

14
racket/src/racket/src/struct.c
View File

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