Fix bug #66046.
Introduce a 'compilation-source-file-name' fluid that captures the
pre-canonicalized file name used when compiling a file, before it gets
modified in fport_canonicalize_filename. That reference that can then
used directly by 'include', avoiding problems.
* module/ice-9/boot-9.scm (compilation-source-file-name): New fluid.
(compile-file): Set it to the value of FILE.
(compile-and-load): Likewise.
* module/ice-9/psyntax.scm (call-with-include-port): Use it.
---
(no changes since v1)
module/ice-9/boot-9.scm | 6 ++++++
module/ice-9/psyntax.scm | 13 +++++++++----
module/system/base/compile.scm | 6 ++++--
3 files changed, 19 insertions(+), 6 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a5f2eea9b..7f2a02007 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -395,6 +395,12 @@ If returning early, return the return value of F."
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
+;;; This fluid captures the original compiled source file name, before
+;;; it gets potentially stripped by the file ports canonicalization. It
+;;; is used with 'include' to locate the true source, which is necessary
+;;; when using relative paths during compilation, for example.
+(define compilation-source-file-name (make-fluid #f))
+
;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
;; The binding for `macroexpand' has now been overridden, making psyntax the
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7811f7118..ccdd15fca 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3260,15 +3260,20 @@
(let ((syntax-dirname (lambda (stx)
(define src (syntax-source stx))
(define filename (and src (assq-ref src 'filename)))
- (and (string? filename)
- (dirname filename)))))
+ (define source-file-name
+ (fluid-ref compilation-source-file-name))
+ (or (and source-file-name
+ (dirname source-file-name))
+ (and (string? filename)
+ (dirname filename))))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename)))
"Like @code{call-with-input-file}, except relative paths are
-searched relative to the @var{dirname} instead of the current working
+searched relative to @var{dirname} instead of the current working
directory. Also, @var{filename} can be a syntax object; in that case,
and if @var{dirname} is not specified, the @code{syntax-source} of
@var{filename} is used to obtain a base directory for relative file
-names."
+names. As a special case, when the @var{compilation-source-file-name}
+fluid is set, its value overrides the @var{dirname} argument provided."
(let* ((filename (syntax->datum filename))
(p (open-input-file
(cond ((absolute-file-name? filename)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index a33d012bd..7b2670c21 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -174,7 +174,8 @@
(opts '())
(canonicalization 'relative))
(validate-options opts)
- (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (with-fluids ((%file-port-name-canonicalization canonicalization)
+ (compilation-source-file-name file))
(let* ((comp (or output-file (compiled-file-name file)
(error "failed to create path for auto-compiled file"
file)))
@@ -202,7 +203,8 @@
(opts '())
(canonicalization 'relative))
(validate-options opts)
- (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (with-fluids ((%file-port-name-canonicalization canonicalization)
+ (compilation-source-file-name file))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts
#:optimization-level optimization-level
--
2.41.0
