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

racket/fasl: use current-directory for relative-path unmarshaling

Browse Source 
Relative-path handling for `fasl->s-exp` was meant to be like code
unmarshaling, but it did not fall back to `(current-directory)` when
`(current-load-relative-directory)` is #f. There's some risk to
changing the behavior of `fasl->s-exp`, but better matching the intent
seems at least as likely to fix problems as create them. One problem
it fixes is in CS code marshaling.

Closes racket/drracket#421 (again)
This commit is contained in:
Matthew Flatt 2021-01-26 11:26:56 -07:00
parent 91060487ca
commit e110b07cc8
6 changed files with 64 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -62,7 +62,8 @@ structures. Compose @racket[s-exp->fasl] with @racket[serialize] to
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
@racket[current-load-relative-directory]
(falling back to @racket[current-directory]), respectively, in the same
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"]).

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

@ -154,15 +154,16 @@
(let* ([file-p (build-path "data.rktd")]
[dir-p (build-path "nested")]
[rel-p (build-path dir-p file-p)]
[p (build-path (current-directory) rel-p)])
[p (build-path (current-directory) rel-p)]
[unnested-p (build-path (current-directory) file-p)])
(define-values (bstr srcloc-bstr)
(parameterize ([current-write-relative-directory (current-directory)])
(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 (srcloc rel-p 10 20 30 40) fasl->s-exp srcloc-bstr))
(test p fasl->s-exp bstr)
(test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr))
(parameterize ([current-load-relative-directory (current-directory)])
(test p fasl->s-exp bstr)
(test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr))
@ -179,10 +180,10 @@
(s-exp->fasl alt-p)
(s-exp->fasl (srcloc alt-p 10 20 30 40)))))
(parameterize ([current-load-relative-directory #f])
(test file-p fasl->s-exp bstr)
(test (srcloc file-p 10 20 30 40) fasl->s-exp srcloc-bstr)
(test (build-path 'up alt-rel-p) fasl->s-exp bstr2)
(test (srcloc (build-path 'up alt-rel-p) 10 20 30 40) fasl->s-exp srcloc-bstr2))
(test unnested-p fasl->s-exp bstr)
(test (srcloc unnested-p 10 20 30 40) fasl->s-exp srcloc-bstr)
(test (build-path (current-directory) 'up alt-rel-p) fasl->s-exp bstr2)
(test (srcloc (build-path (current-directory) 'up alt-rel-p) 10 20 30 40) fasl->s-exp srcloc-bstr2))
(parameterize ([current-load-relative-directory (build-path (current-directory) dir-p)])
(test p fasl->s-exp bstr)
(test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr)
@ -203,7 +204,7 @@
(fasl->s-exp (s-exp->fasl root))))
(test
(build-path 'same)
(build-path (current-directory) 'same)
'this-dir-path
(parameterize ([current-write-relative-directory root]
[current-load-relative-directory #f])

41
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -3537,6 +3537,47 @@ case of module-leve bindings; it doesn't cover local bindings.
;; will be 6 instead of 5:
(test 5 dynamic-require ''uses-module-out-of-thin-air 'also-five)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check relative-path encoding and decoding for procedure source locations
(let ([m (compile `(module m racket/base
(provide f)
(define f ,(datum->syntax #f
`(lambda (thunk) (list (thunk)))
(list (build-path (current-directory) "the-file.rkt")
2
3
4
5)))))])
(define o (open-output-bytes))
(parameterize ([current-write-relative-directory (current-directory)])
(write m o))
(define (get)
(parameterize ([read-accept-compiled #t])
(read (open-input-bytes (get-output-bytes o)))))
(define (check-name m p)
(parameterize ([current-namespace (make-base-namespace)])
(eval m)
(define f (dynamic-require ''m 'f))
(define e (with-handlers ([exn:fail? values])
(f (lambda () (car 0)))))
(define ctx (continuation-mark-set->context (exn-continuation-marks e)))
(test
#t
`(has ,p)
(for/or ([pr (in-list ctx)])
(printf ">> ~s\n" (cdr pr))
(and (cdr pr)
(equal? p (srcloc-source (cdr pr))))))))
(let ([m1 (parameterize ([current-load-relative-directory #f])
(get))])
(check-name m1 (build-path (current-directory) "the-file.rkt"))
(void))
(let ([m1 (parameterize ([current-load-relative-directory (find-system-path 'temp-dir)])
(get))])
(check-name m1 (build-path (find-system-path 'temp-dir) "the-file.rkt"))
(void)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

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

@ -465,7 +465,8 @@
[(fasl-path-type) (bytes->path (read-fasl-bytes i)
(loop))]
[(fasl-relative-path-type)
(define wrt-dir (current-load-relative-directory))
(define wrt-dir (or (current-load-relative-directory)
(current-directory)))
(define rel-elems (for/list ([p (in-list (loop))])
(if (bytes? p) (bytes->path-element p) p)))
(cond

6
racket/src/cs/schemified/expander.scm
View File

@ -23263,7 +23263,11 @@
(if (unsafe-fx< index_0 26)
(if (unsafe-fx< index_0 25)
(let ((wrt-dir_0
(current-load-relative-directory)))
(let ((or-part_0
(current-load-relative-directory)))
(if or-part_0
or-part_0
(current-directory)))))
(let ((rel-elems_0
(reverse$1
(let ((lst_0

6
racket/src/cs/schemified/schemify.scm
View File

@ -38816,7 +38816,11 @@
(if (unsafe-fx< index_0 26)
(if (unsafe-fx< index_0 25)
(let ((wrt-dir_0
(current-load-relative-directory)))
(let ((or-part_0
(current-load-relative-directory)))
(if or-part_0
or-part_0
(current-directory)))))
(let ((rel-elems_0
(reverse$1
(let ((lst_0