diff --git a/pkgs/racket-doc/scribblings/reference/fasl.scrbl b/pkgs/racket-doc/scribblings/reference/fasl.scrbl index 815be9b61b..0b6813d65f 100644 --- a/pkgs/racket-doc/scribblings/reference/fasl.scrbl +++ b/pkgs/racket-doc/scribblings/reference/fasl.scrbl @@ -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"]). diff --git a/pkgs/racket-test-core/tests/racket/fasl.rktl b/pkgs/racket-test-core/tests/racket/fasl.rktl index 32ac9ef14c..b255f7a67d 100644 --- a/pkgs/racket-test-core/tests/racket/fasl.rktl +++ b/pkgs/racket-test-core/tests/racket/fasl.rktl @@ -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]) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index 7046c65288..f9bd7acbce 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -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) diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index 683253e00e..4368414dae 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -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 diff --git a/racket/src/cs/schemified/expander.scm b/racket/src/cs/schemified/expander.scm index 33517a6f49..86386ce2be 100644 --- a/racket/src/cs/schemified/expander.scm +++ b/racket/src/cs/schemified/expander.scm @@ -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 diff --git a/racket/src/cs/schemified/schemify.scm b/racket/src/cs/schemified/schemify.scm index 6245bd5f4f..80d3ea061a 100644 --- a/racket/src/cs/schemified/schemify.scm +++ b/racket/src/cs/schemified/schemify.scm @@ -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