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

[Maxim Cournoyer]

Fixes bug #66046.

Introduce a '%file-port-stripped-prefixes' 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 by 'include' when searching for included files.

* libguile/fports.c (sys_file_port_stripped_prefixes): New C fluid.
(fport_canonicalize_filename): Register dirnames / stripped prefixes
pairs in.
(%file-port-stripped-prefixes): New corresponding Scheme fluid.
* module/ice-9/boot-9.scm (call-with-include-port): New procedure,
shadowing that from psyntax, that extends it to use the above fluid to
compute a fallback include file directory name to try.
* module/ice-9/psyntax.scm (call-with-include-port): Add comment.  Strip
documentation, as it's now an internal.

---

Changes in v2:
 - Move fluid to where the file name stripping happens, in libguile
 - Make the fluid value an alist of the last 100 stripped prefixes
 - Expound test to catch edge case (include in an include)

 libguile/fports.c              | 41 +++++++++++++++++++++--
 module/ice-9/boot-9.scm        | 61 ++++++++++++++++++++++++++++++++++
 module/ice-9/psyntax.scm       |  8 ++---
 test-suite/tests/compiler.test |  8 ++---
 4 files changed, 106 insertions(+), 12 deletions(-)

diff --git a/libguile/fports.c b/libguile/fports.c
index 8f19216b7..12048828a 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006-2015,2017-2020,2022
+/* Copyright 1995-2004,2006-2015,2017-2020,2022-2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -43,6 +43,7 @@
 #include <sys/select.h>
 #include <full-write.h>
 
+#include "alist.h"
 #include "async.h"
 #include "boolean.h"
 #include "dynwind.h"
@@ -59,6 +60,7 @@
 #include "ports-internal.h"
 #include "posix.h"
 #include "read.h"
+#include "srfi-13.h"
 #include "strings.h"
 #include "symbols.h"
 #include "syscalls.h"
@@ -123,6 +125,7 @@ SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
 
 
 static SCM sys_file_port_name_canonicalization;
+static SCM sys_file_port_stripped_prefixes;
 static SCM sym_relative;
 static SCM sym_absolute;
 
@@ -143,7 +146,34 @@ fport_canonicalize_filename (SCM filename)
                                                     "%load-path"));
       rel = scm_i_relativize_path (filename, path);
 
-      return scm_is_true (rel) ? rel : filename;
+      if (scm_is_true (rel))
+        {
+          SCM relative_dir = scm_dirname (rel);
+          SCM stripped_prefixes = scm_fluid_ref
+            (sys_file_port_stripped_prefixes);
+
+          /* Extend the association list if needed, but keep its size
+             capped to limit memory usage. */
+          if (scm_is_false (scm_assoc_ref(stripped_prefixes, relative_dir)))
+            {
+              SCM stripped_prefix = scm_string_drop_right
+                (filename, scm_string_length (rel));
+
+              stripped_prefixes = scm_cons (scm_cons (relative_dir,
+                                                      stripped_prefix),
+                                            stripped_prefixes);
+
+              if (scm_to_int (scm_length (stripped_prefixes)) > 100)
+                stripped_prefixes = scm_list_head (stripped_prefixes,
+                                                   scm_from_int(100));
+
+              scm_fluid_set_x (sys_file_port_stripped_prefixes,
+                               stripped_prefixes);
+            }
+
+          return rel;
+        }
+      return filename;
     }
   else if (scm_is_eq (mode, sym_absolute))
     {
@@ -766,4 +796,11 @@ scm_init_fports ()
   sys_file_port_name_canonicalization = scm_make_fluid ();
   scm_c_define ("%file-port-name-canonicalization",
                 sys_file_port_name_canonicalization);
+
+  /* Used by `include' to locate the true source when relative
+     canonicalization strips a leading part of the source file. */
+  sys_file_port_stripped_prefixes = scm_make_fluid_with_default (SCM_EOL);
+
+  scm_c_define ("%file-port-stripped-prefixes",
+                sys_file_port_stripped_prefixes);
 }
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a5f2eea9b..a79d49ae1 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2030,6 +2030,67 @@ non-locally, that exit determines the continuation."
 
 
 
+;;; {Include}
+;;;
+
+;;; This redefined version of call-with-include-port (first defined in
+;;; psyntax.scm) also try to locate an included file using the
+;;; %file-port-stripped-prefixes fluid.
+(define call-with-include-port
+  (let ((syntax-dirname (lambda (stx)
+                          (define src (syntax-source stx))
+                          (define filename (and src (assq-ref src 'filename)))
+                          (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 @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.  As a special case, when the @var{%file-port-stripped-prefixes}
+fluid is set, its value is searched for a directory matching the dirname
+inferred from FILENAME."
+      (let* ((filename (syntax->datum filename))
+             (candidates
+              (cond ((absolute-file-name? filename)
+                     (list filename))
+                    (dirname            ;filename is relative
+                     (let* ((rel-names (fluid-ref 
%file-port-stripped-prefixes))
+                            (stripped-prefix (and rel-names
+                                                  (assoc-ref rel-names 
dirname)))
+                            (fallback (and stripped-prefix
+                                           (string-append stripped-prefix
+                                                          dirname))))
+                       (map (lambda (d)
+                              (in-vicinity d filename))
+                            `(,dirname ,@(if fallback
+                                             (list fallback)
+                                             '())))))
+                    (else
+                     (error
+                      "attempt to include relative file name \
+but could not determine base dir"))))
+             (p (let loop ((files candidates))
+                  (when (null? files)
+                    (error "could not open any of" candidates))
+                  (catch 'system-error
+                    (lambda _
+                      (open-input-file (car files)))
+                    (lambda _
+                      (loop (cdr files))))))
+             (enc (file-encoding p)))
+
+        ;; Choose the input encoding deterministically.
+        (set-port-encoding! p (or enc "UTF-8"))
+
+        (call-with-values (lambda () (proc p))
+          (lambda results
+            (close-port p)
+            (apply values results)))))))
+
+
+
 ;;; {Time Structures}
 ;;;
 
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 7811f7118..0e0370457 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3256,6 +3256,8 @@
         ;; Scheme code corresponding to the intermediate language forms.
         ((_ e) (emit (quasi #'e 0))))))) 
 
+;; Note: this procedure is later refined in ice-9/boot-9.scm after we
+;; have basic exception handling.
 (define call-with-include-port
   (let ((syntax-dirname (lambda (stx)
                           (define src (syntax-source stx))
@@ -3263,12 +3265,6 @@
                           (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
-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."
       (let* ((filename (syntax->datum filename))
              (p (open-input-file
                  (cond ((absolute-file-name? filename)
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ff923095a..79aee1a0e 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -501,13 +501,13 @@
        #t)
 
      ;; This used to fail, because compile-file's #:canonicalization
-     ;; defaults to 'relative, which caused 'scm_relativize_path' to
+     ;; defaults to 'relative, which causes 'scm_relativize_path' to
      ;; strip the prefix not in the load path, to avoid baking an
      ;; invalid source file reference in the byte compiled output file
      ;; (see: https://bugs.gnu.org/66046).  This was fixed by having a
-     ;; 'compilation-source-file' fluid that preserves the file name
-     ;; passed to 'compile-file', used by 'include' instead of the file
-     ;; name of the port.
+     ;; '%file-port-stripped-prefixes' fluid to preserve the stripped
+     ;; prefix, to be used by 'include' to reconstruct the original
+     ;; complete relative file name.
      (pass-if "relative include works with load path canonicalization"
        (add-to-load-path (string-append (getcwd) "/../module"))
        (compile-file "../module/hello.scm" #:output-file "hello.go")
-- 
2.41.0