bug#66046: [PATCH 2/2] ice-9: Fix 'include' when used in compilation contexts.

[Maxim Cournoyer]

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.

---

 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