bug#66046: Relative includes in R7RS define-library seem broken

bug#66046: Relative includes in R7RS define-library seem broken

[Daphne Preston-Kendal]

A standard layout for R7RS libraries is to have an .sld file
containing the library import and export declarations with a parallel
.scm file with the same name in the same directory, which the .sld
file (include ...)s.

E.g. lib/dpk/mylibrary.sld:

(define-library (dpk mylibrary)
  (import (scheme base))
  (export make-frob #;etc)
  (include "mylibrary.scm"))

and then mylibrary.scm is also in the same lib/dpk directory as
mylibrary.scm and includes the actual code.

Guile supports looking for .sld files before .scm files if started in
--r7rs mode. However, in this case, it will not find the .scm file if
it’s included from the .sld file.

Starting Guile with: guile --r7rs -L './lib'
or by setting the GUILE_LOAD_PATH environment variable, (in both cases
with absolute paths or relative ones) and attempting to import
libraries such as this results in a file not found error for the
included .scm file, e.g.:

scheme@(guile-user)> (import (chibi shell))
;;; note: source file /Users/dpk/Projects/r7rs/lib/chibi/shell.sld
;;;       newer than compiled /Users/dpk/.cache/guile/ccache/3.0-LE-8-4.6/Users/dpk/Projects/r7rs/lib/chibi/shell.sld.go
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling /Users/dpk/Projects/r7rs/lib/chibi/shell.sld
;;; WARNING: compilation of /Users/dpk/Projects/r7rs/lib/chibi/shell.sld failed:
;;; In procedure open-file: No such file or directory: "chibi/shell.scm"
scheme@(guile-user)> 

Curiously, including a file which *actually* doesn’t exist results in
two different, one of which correctly reports the full path of the
file it’s purportedly trying to include:

scheme@(guile-user)> (import (chibi shell))
;;; note: source file /Users/dpk/Projects/r7rs/lib/chibi/shell.sld
;;;       newer than compiled /Users/dpk/.cache/guile/ccache/3.0-LE-8-4.6/Users/dpk/Projects/r7rs/lib/chibi/shell.sld.go
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling /Users/dpk/Projects/r7rs/lib/chibi/shell.sld
;;; WARNING: compilation of /Users/dpk/Projects/r7rs/lib/chibi/shell.sld failed:
;;; In procedure open-file: No such file or directory: "chibi/wonderpants.scm"
While compiling expression:
In procedure open-file: No such file or directory: "/Users/dpk/Projects/r7rs/lib/chibi/wonderpants.scm"
scheme@(guile-user)> 

So this smells like a bug where the part of the R7RS library code
looks in the wrong place and fails, but after it’s already failed, a
second part of the code looks again in the correct location and
reports another error if the file really didn’t exist. This is a
strange hypothesis but it’s the only thing I can think of.

Changing the path in the include declaration to be absolute fixes the
problem, but then it no longer works on other people’s machines.

Guile version: 3.0.9
installed from nix-unstable

bug#66046: Relative includes in R7RS define-library seem broken

[Timothy Sample]

Hi Daphne,

Daphne Preston-Kendal <dpk@nonceword.org> writes:

> A standard layout for R7RS libraries is to have an .sld file
> containing the library import and export declarations with a parallel
> .scm file with the same name in the same directory, which the .sld
> file (include ...)s.
>
> [...]
>
> Guile supports looking for .sld files before .scm files if started in
> --r7rs mode. However, in this case, it will not find the .scm file if
> it’s included from the .sld file.

This is currently causing me problems, too, so I will look into writing
and submitting a patch.

We are technically following R7RS, which says the lookup strategy is
“implementation-specific”.  However, it goes on to say: “implementations
are encouraged to search for files in the directory which contains the
including file [...].”  This is perfectly reasonable, and like you say,
part of an established pattern for portable code.

> Changing the path in the include declaration to be absolute fixes the
> problem, but then it no longer works on other people’s machines.

FWIW, I’ve settled on this (annoying) pattern for now:

    (cond-expand
     (guile
      (import (only (guile) include-from-path))
      (begin (include-from-path "relative/from/load/path/foo.scm")))
     (else
      (include "foo.scm")))

I wouldn’t bother with it if I weren’t committed to Guile, though!


-- Tim

bug#66046: Relative includes in R7RS define-library seem broken

[Maxim Cournoyer]

Hi,

I also encountered that problem while working on adding new SRFIs to
Guile.

Timothy Sample <samplet@ngyro.com> writes:

> Hi Daphne,
>
> Daphne Preston-Kendal <dpk@nonceword.org> writes:
>
>> A standard layout for R7RS libraries is to have an .sld file
>> containing the library import and export declarations with a parallel
>> .scm file with the same name in the same directory, which the .sld
>> file (include ...)s.
>>
>> [...]
>>
>> Guile supports looking for .sld files before .scm files if started in
>> --r7rs mode. However, in this case, it will not find the .scm file if
>> it’s included from the .sld file.
>
> This is currently causing me problems, too, so I will look into writing
> and submitting a patch.
>
> We are technically following R7RS, which says the lookup strategy is
> “implementation-specific”.  However, it goes on to say: “implementations
> are encouraged to search for files in the directory which contains the
> including file [...].”  This is perfectly reasonable, and like you say,
> part of an established pattern for portable code.

That's what Guile does (it attempts to locate the directory of the
including source file), but helas, it happens after the file port
corresponding to the including file has been relativized, which appears
ot strip the prefix of its file name that is in the load path.

e.g.: ../module/srfi/srfi-151.scm --> srfi/srfi-151.scm

This NEWS entry describes the '%file-port-name-canonicalization' which
is used in 'compile-file' and friends:

--8<---------------cut here---------------start------------->8---
** New fluid: `%file-port-name-canonicalization'
    
This fluid parameterizes the file names that are associated with file
ports.  If %file-port-name-canonicalization is 'absolute, then file names
are canonicalized to be absolute paths. If it is 'relative, then the
name is canonicalized, but any prefix corresponding to a member of
`%load-path' is stripped off.  Otherwise the names are passed through
unchanged.

In addition, the `compile-file' and `compile-and-load' procedures bind
%file-port-name-canonicalization to their `#:canonicalization' keyword
argument, which defaults to 'relative. In this way, one might compile
"../module/ice-9/boot-9.scm", but the path that gets residualized into
the .go is "ice-9/boot-9.scm".
--8<---------------cut here---------------end--------------->8---

Perhaps there's a better way to avoid baking a bad reference in the .go
file without changing fundamental truths about file names, as this is
what breaks 'include'.

I tried setting the original file name to a parameter in compile-file
and compile-file-load, but given 'include' is a syntax, this cannot
work.  I'll try studying if an alternative to stripping can be used to
avoid baking bad file names in .go files.

-- 
Thanks,
Maxim

bug#66046: Relative includes in R7RS define-library seem broken

[Maxim Cournoyer]

Hi,

[...]

> That's what Guile does (it attempts to locate the directory of the
> including source file), but helas, it happens after the file port
> corresponding to the including file has been relativized, which appears
> ot strip the prefix of its file name that is in the load path.
>
> e.g.: ../module/srfi/srfi-151.scm --> srfi/srfi-151.scm

To illustrate this is indeed the problem, this diff allow include to
find the source file:

--8<---------------cut here---------------start------------->8---
modified   module/system/base/compile.scm
@@ -172,7 +172,7 @@
                        (optimization-level (default-optimization-level))
                        (warning-level (default-warning-level))
                        (opts '())
-                       (canonicalization 'relative))
+                       (canonicalization 'none))
   (validate-options opts)
   (with-fluids ((%file-port-name-canonicalization canonicalization))
     (let* ((comp (or output-file (compiled-file-name file)
@@ -200,7 +200,7 @@
                            (optimization-level (default-optimization-level))
                            (warning-level (default-warning-level))
                            (opts '())
-                           (canonicalization 'relative))
+                           (canonicalization 'none))
   (validate-options opts)
   (with-fluids ((%file-port-name-canonicalization canonicalization))
     (read-and-compile (open-input-file file)
--8<---------------cut here---------------end--------------->8---

This appears to be a 13 year old regression introduced with commit
0157a341577223a981d912c93b568792e9dc67e3 ("add
%file-port-name-canonicalization option"):

--8<---------------cut here---------------start------------->8---
Date:   Mon Apr 19 13:14:43 2010 +0200

    add %file-port-name-canonicalization option
    
    * libguile/fports.c (%file-port-name-canonicalization): New global var.
      (fport_canonicalize_filename): New helper. If
      %file-port-name-canonicalization is 'absolute, then run file port
      names through canonicalize_path; if it's 'relative, then canonicalize
      the name, but strip off load paths; otherwise leave the port name
      alone.
      (scm_open_file): Use fport_canonicalize_filename.
      (scm_init_fports): Define %file-port-name-canonicalization.
--8<---------------cut here---------------end--------------->8---

I'm now curious to know what was the rationale behind this change; I
gather it may have only been to avoid registering bogus source paths in
the generated .go file, as hinted by the NEWS file.  If that's
confirmed, then the solution could be to find another way to accomplish
the same without touching a file port's associated file name metadata.

-- 
Thanks,
Maxim

bug#66046: Relative includes in R7RS define-library seem broken

[Maxim Cournoyer]

[-- Attachment #1: Type: text/plain, Size: 54 bytes --]

Hello,

Here's a new test that reproduces the issue:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 3164 bytes --]

1 file changed, 65 insertions(+)
test-suite/tests/compiler.test | 65 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

modified   test-suite/tests/compiler.test
@@ -18,6 +18,7 @@
 (define-module (tests compiler)
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
+  #:use-module (ice-9 ftw)
   #:use-module (system base compile)
   #:use-module ((language tree-il)
                 #:select (tree-il-src call-args))
@@ -27,6 +28,39 @@
 (define read-and-compile
   (@@ (system base compile) read-and-compile))
 
+;;; Based on 'with-directory-excursion', from (guix build utils).
+(define-syntax-rule (with-temporary-directory body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd))
+        (dir (mkdtemp "tempdir.XXXXXX")))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)
+       (delete-file-recursively dir)))))
+
+;;; XXX: Adapted from (guix build utils).
+(define* (delete-file-recursively dir)
+  "Delete DIR recursively, like `rm -rf', without following symlinks."
+  (file-system-fold (const #t)          ;enter
+                    (lambda (file stat result)   ; leaf
+                      (delete-file file))
+                    (const #t)                   ; down
+                    (lambda (dir stat result)    ; up
+                      (rmdir dir))
+                    (const #t)                   ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "warning: failed to delete ~a: ~a~%"
+                              file (strerror errno)))
+                    #t
+                    dir
+
+                    ;; Don't follow symlinks.
+                    lstat))
 
 \f
 (with-test-prefix "basic"
@@ -434,3 +468,34 @@
         (set! proc ((load-thunk-from-memory bytecode)))
         (procedure? proc)))
     (pass-if-equal "proc executes" 42 (proc))))
+
+(with-test-prefix "compile-file"
+  ;; Setup test library sources in a temporary directory.
+  (let ((top-sexp '(define-library (hello)
+                     (import (scheme base)
+                             (scheme write))
+                     (export hello)
+                     (include "hello/hello-impl.scm")))
+        (included-sexp '(define (hello)
+                          (display "hello!\n"))))
+    (with-temporary-directory
+     (mkdir "module")
+     (call-with-output-file "module/hello.scm"
+       (lambda (port)
+         (write top-sexp port)))
+     (mkdir "module/hello")
+     (call-with-output-file "module/hello/hello-impl.scm"
+       (lambda (port)
+         (write included-sexp port)))
+     (mkdir "build")
+     (chdir "build")
+
+     (pass-if "relative include works"
+       (compile-file "../module/hello.scm" #:output-file "hello.go")
+       #t)
+
+     (pass-if "relative include works with load path canonicalization"
+       (begin
+         (add-to-load-path (string-append (getcwd) "/../module"))
+         (compile-file "../module/hello.scm" #:output-file "hello.go")
+         #t)))))

[-- Attachment #3: Type: text/plain, Size: 986 bytes --]


I run it like:

--8<---------------cut here---------------start------------->8---
./meta/guile -L test-suite -L . test-suite/tests/compiler.test
--8<---------------cut here---------------end--------------->8---

And I see:

--8<---------------cut here---------------start------------->8---
ERROR: compile-file: relative include works with load path canonicalization - arguments: ((system-error "open-file" "~A: ~S" ("Aucun fichier ou dossier de ce type" "./hello/hello-impl.scm") (2)))
--8<---------------cut here---------------end--------------->8---

That's the include directive failing because scm_i_relativize_path
caused the path to be stripped from "../module/hello.scm" to
"hello.scm"; then include, through its call-with-include-port helper,
calls (dirname "hello.scm"), which produces ".".

Finally, the same helper calls (in-vicinity "." "hello/hello-impl.scm"),
which produces the unresolvable "./hello/hello-impl.scm" file name seen
in the error above.

-- 
Thanks,
Maxim

bug#66046: [PATCH 1/2] tests: Add new compile-file tests.

[Maxim Cournoyer]

Add a test for bug #66046.

To run just the compiler tests:

  ./meta/guile -L test-suite -L . test-suite/tests/compiler.test

* test-suite/tests/compiler.test (with-temporary-directory): New syntax.
(delete-file-recursively): New procedure.
("compile-file: relative include works")
("compile-file: relative include works with load path
canonicalization"): New tests.
---

 test-suite/tests/compiler.test | 75 +++++++++++++++++++++++++++++++++-
 1 file changed, 74 insertions(+), 1 deletion(-)

diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index a018e0c41..2026d5ff3 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021-2022 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-2023 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,6 +18,7 @@
 (define-module (tests compiler)
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
+  #:use-module (ice-9 ftw)
   #:use-module (system base compile)
   #:use-module ((language tree-il)
                 #:select (tree-il-src call-args))
@@ -27,6 +28,39 @@
 (define read-and-compile
   (@@ (system base compile) read-and-compile))
 
+;;; Based on 'with-directory-excursion', from (guix build utils).
+(define-syntax-rule (with-temporary-directory body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd))
+        (dir (mkdtemp "tempdir.XXXXXX")))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)
+       (delete-file-recursively dir)))))
+
+;;; XXX: Adapted from (guix build utils).
+(define* (delete-file-recursively dir)
+  "Delete DIR recursively, like `rm -rf', without following symlinks."
+  (file-system-fold (const #t)          ;enter
+                    (lambda (file stat result)   ; leaf
+                      (delete-file file))
+                    (const #t)                   ; down
+                    (lambda (dir stat result)    ; up
+                      (rmdir dir))
+                    (const #t)                   ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "warning: failed to delete ~a: ~a~%"
+                              file (strerror errno)))
+                    #t
+                    dir
+
+                    ;; Don't follow symlinks.
+                    lstat))
 
 \f
 (with-test-prefix "basic"
@@ -434,3 +468,42 @@
         (set! proc ((load-thunk-from-memory bytecode)))
         (procedure? proc)))
     (pass-if-equal "proc executes" 42 (proc))))
+
+(with-test-prefix "compile-file"
+  ;; Setup test library sources in a temporary directory.
+  (let ((top-sexp '(define-library (hello)
+                     (import (scheme base)
+                             (scheme write))
+                     (export hello)
+                     (include "hello/hello-impl.scm")))
+        (included-sexp '(define (hello)
+                          (display "hello!\n"))))
+    (with-temporary-directory
+     (mkdir "module")
+     (call-with-output-file "module/hello.scm"
+       (lambda (port)
+         (write top-sexp port)))
+     (mkdir "module/hello")
+     (call-with-output-file "module/hello/hello-impl.scm"
+       (lambda (port)
+         (write included-sexp port)))
+     (mkdir "build")
+     (chdir "build")
+
+     (pass-if "relative include works"
+       (compile-file "../module/hello.scm" #:output-file "hello.go")
+       #t)
+
+     ;; This used to fail, because compile-file's #:canonicalization
+     ;; defaults to 'relative, which caused '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.
+     (pass-if "relative include works with load path canonicalization"
+       (begin
+         (add-to-load-path (string-append (getcwd) "/../module"))
+         (compile-file "../module/hello.scm" #:output-file "hello.go")
+         #t)))))

base-commit: 75cd95060fb1ea7586f0e4b9081694c6d61f1d3b
-- 
2.41.0

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

bug#66046: Relative includes in R7RS define-library seem broken

[Amirouche]

If I am not mistaken, the patch is not backward compatible.

The problem with the current patch is that it force the included file 
to be next to the including file, there is no fallback  mechanism. 
The algorithm should be dynamic using an ordered list a priority to
the favorite behavior. 

The most relevant hunk is:

--- 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))))))

Here the code says: the included file must be in (syntax-dirname). 
It is preferable to have fallbacks, to be backward compatible.

`syntax-dirname' must be `syntax-dirnames' to return candidate directories 
sorted list with biggest priority coming first where to find included 
files.

Also, mind the use of the fluid and how it interact with parallel compilation.

BR

ref: https://github.com/justinethier/cyclone/issues/494#issuecomment-1328958946
ref: https://github.com/justinethier/cyclone/commit/ab25e360a9d7b67c2e5eda086001ca0761a3f34f#diff-b9136575f3ccbf09887d1da9fb4b6e136e4e32a839c10cf855696ec1cf6add4bR54-R58

bug#66046: Relative includes in R7RS define-library seem broken

[Maxim Cournoyer]

Hello,

Amirouche <amirouche@hyper.dev> writes:

> If I am not mistaken, the patch is not backward compatible.
>
> The problem with the current patch is that it force the included file 
> to be next to the including file, there is no fallback  mechanism. 
> The algorithm should be dynamic using an ordered list a priority to
> the favorite behavior. 
>
> The most relevant hunk is:
>
> --- 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))))))
>
> Here the code says: the included file must be in (syntax-dirname). 
> It is preferable to have fallbacks, to be backward compatible.

It also falls back to the existing behavior, which is of picking up the
parent directory of the port's file name (that is, the parent directory
of the source file using the 'include' syntax), per the 'or' above.
Isn't that sufficient?

> `syntax-dirname' must be `syntax-dirnames' to return candidate directories 
> sorted list with biggest priority coming first where to find included 
> files.

I'm not sure what algorithm you are suggesting here; but it seems it'd
be something new in Guile.  Since the behavior of 'include' is not
standardized, I'd prefer we change it only if there are interesting use
cases not yet covered (can you think of a scenario?  we could add a test
for it).

> Also, mind the use of the fluid and how it interact with parallel compilation.

Fluids are thread safe, as far as I know, and files are compiled one at
a time anyway, so I don't foresee any problem here, as you also noted in
#scheme on Libera.

-- 
Thanks,
Maxim

bug#66046: Relative includes in R7RS define-library seem broken

[Maxim Cournoyer]

Hello,

I've just found a cross-compilation buggy interaction with my fix:

--8<---------------cut here---------------start------------->8---
$ touch ./module/srfi/srfi-151.scm 
maxim@hurd ~/src/guile [env]$ touch ./module/srfi/srfi-160/base.sld 
maxim@hurd ~/src/guile [env]$ m
make  all-recursive
make[1]: Entering directory '/home/maxim/src/guile'
Making all in lib
make[2]: Entering directory '/home/maxim/src/guile/lib'
make  all-recursive
make[3]: Entering directory '/home/maxim/src/guile/lib'
make[4]: Entering directory '/home/maxim/src/guile/lib'
make[4]: Nothing to be done for 'all-am'.
make[4]: Leaving directory '/home/maxim/src/guile/lib'
make[3]: Leaving directory '/home/maxim/src/guile/lib'
make[2]: Leaving directory '/home/maxim/src/guile/lib'
Making all in meta
make[2]: Entering directory '/home/maxim/src/guile/meta'
make[2]: Nothing to be done for 'all'.
make[2]: Leaving directory '/home/maxim/src/guile/meta'
Making all in libguile
make[2]: Entering directory '/home/maxim/src/guile/libguile'
make  all-am
make[3]: Entering directory '/home/maxim/src/guile/libguile'
make[3]: Nothing to be done for 'all-am'.
make[3]: Leaving directory '/home/maxim/src/guile/libguile'
make[2]: Leaving directory '/home/maxim/src/guile/libguile'
Making all in module
make[2]: Entering directory '/home/maxim/src/guile/module'
make[2]: Nothing to be done for 'all'.
make[2]: Leaving directory '/home/maxim/src/guile/module'
Making all in stage0
make[2]: Entering directory '/home/maxim/src/guile/stage0'
  BOOTSTRAP(stage0) GUILEC srfi/srfi-151.go
  BOOTSTRAP(stage0) GUILEC srfi/srfi-160/base.go
;;; note: source file /home/maxim/src/guile/module/srfi/srfi-151.scm
;;;       newer than compiled /home/maxim/src/guile/stage0/srfi/srfi-151.go
;;; note: source file /home/maxim/src/guile/module/srfi/srfi-151.scm
;;;       newer than compiled /home/maxim/src/guile/cache/guile/ccache/3.0-LE-8-4.6/home/maxim/src/guile/module/srfi/srfi-151.scm.go
Backtrace:
In ice-9/r6rs-libraries.scm:
   113:17 19 (_ #<syntax:base.sld:5:16 (#<syntax:base.sld:5:17 srfi?> ?)
In ice-9/boot-9.scm:
  3355:17 18 (resolve-interface (srfi srfi-151) #:select _ #:hide _ # ?)
In ice-9/threads.scm:
    397:8 17 (_ #<procedure 7f94a9df2a00 at ice-9/boot-9.scm:3269:7 ?>)
In ice-9/boot-9.scm:
  3281:13 16 (_)
In ice-9/threads.scm:
    397:8 15 (_ #<procedure 7f94a9d7a180 at ice-9/boot-9.scm:3565:5 ?>)
In ice-9/boot-9.scm:
  3572:20 14 (_)
   2864:4 13 (save-module-excursion #<procedure 7f94a6d85b10 at ice-?>)
  3592:26 12 (_)
In unknown file:
          11 (primitive-load-path "srfi/srfi-151" #<procedure 7f94a9?>)
In ice-9/eval.scm:
   721:20 10 (primitive-eval (define-library (srfi srfi-151) (# #) ?))
wrote `srfi/srfi-151.go'
In ice-9/psyntax.scm:
  1229:36  9 (expand-top-sequence (#<syntax:srfi-151.scm:23:0 (def?>) ?)
  1123:16  8 (lp (#<syntax:srfi-151.scm:23:0 (define-library #<syn?>) ?)
  1123:16  7 (lp (#<syntax:srfi-151.scm:23:0 (#<syntax:r6rs-libr?> ?) ?)
  1123:16  6 (lp (#<syntax:srfi-151.scm:23:0 (#<syntax:r7rs-librar?>) ?)
  1121:20  5 (lp (#<syntax:srfi-151.scm:23:0 (#<syntax:base.scm:30?>) ?)
  1342:32  4 (syntax-type (#<syntax:base.scm:301:10 include> #<sy?>) ?)
  1562:32  3 (expand-macro #<procedure 7f94a9c0ed98 at ice-9/psynta?> ?)
  3278:16  2 (_ #<syntax:srfi-151.scm:54:11 "srfi-151/bitwise-33.sc?> ?)
In unknown file:
           1 (open-file "../module/srfi/srfi-160/srfi-151/bitwise-3?" ?)
In ice-9/boot-9.scm:
  1682:22  0 (lp 0)

ice-9/boot-9.scm:1682:22: In procedure lp:
In procedure open-file: No such file or directory: "../module/srfi/srfi-160/srfi-151/bitwise-33.scm"
make[2]: *** [Makefile:2562: srfi/srfi-160/base.go] Error 1
make[2]: Leaving directory '/home/maxim/src/guile/stage0'
make[1]: *** [Makefile:2203: all-recursive] Error 1
make[1]: Leaving directory '/home/maxim/src/guile'
make: *** [Makefile:2088 : all] Erreur 2
--8<---------------cut here---------------end--------------->8---

I'll try to come up with a test case, then a fix.

-- 
Thanks,
Maxim

bug#66046: [PATCH v2 1/3] libguile/fports.c: Remove extraneous include.

[Maxim Cournoyer]

* libguile/fports.c: Delete "hashtab.h" include, which is unused.
---

(no changes since v1)

 libguile/fports.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/libguile/fports.c b/libguile/fports.c
index 9d4ca6ace..8f19216b7 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -52,7 +52,6 @@
 #include "fluids.h"
 #include "gc.h"
 #include "gsubr.h"
-#include "hashtab.h"
 #include "keywords.h"
 #include "modules.h"
 #include "numbers.h"

base-commit: d579848cb5d65440af5afd9c8968628665554c22
-- 
2.41.0

bug#66046: [PATCH v2 2/3] tests: Add new compile-file tests.

[Maxim Cournoyer]

Add a test for bug #66046.

To run just the compiler tests:

  ./meta/guile -L test-suite -L . test-suite/tests/compiler.test

* test-suite/tests/compiler.test (with-temporary-directory): New syntax.
(delete-file-recursively): New procedure.
("compile-file: relative include works")
("compile-file: relative include works with load path
canonicalization"): New tests.
---

(no changes since v1)

 test-suite/tests/compiler.test | 82 +++++++++++++++++++++++++++++++++-
 1 file changed, 80 insertions(+), 2 deletions(-)

diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index a018e0c41..ff923095a 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021-2022 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-2023 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,15 +18,50 @@
 (define-module (tests compiler)
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
+  #:use-module (ice-9 ftw)
   #:use-module (system base compile)
   #:use-module ((language tree-il)
                 #:select (tree-il-src call-args))
   #:use-module ((system vm loader) #:select (load-thunk-from-memory))
-  #:use-module ((system vm program) #:select (program-sources source:addr)))
+  #:use-module ((system vm program) #:select (program-sources source:addr))
+  #:use-module (srfi srfi-26))
 
 (define read-and-compile
   (@@ (system base compile) read-and-compile))
 
+;;; Based on 'with-directory-excursion', from (guix build utils).
+(define-syntax-rule (with-temporary-directory body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd))
+        (dir (mkdtemp "tempdir.XXXXXX")))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)
+       (delete-file-recursively dir)))))
+
+;;; XXX: Adapted from (guix build utils).
+(define* (delete-file-recursively dir)
+  "Delete DIR recursively, like `rm -rf', without following symlinks."
+  (file-system-fold (const #t)          ;enter
+                    (lambda (file stat result)   ; leaf
+                      (delete-file file))
+                    (const #t)                   ; down
+                    (lambda (dir stat result)    ; up
+                      (rmdir dir))
+                    (const #t)                   ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "warning: failed to delete ~a: ~a~%"
+                              file (strerror errno)))
+                    #t
+                    dir
+
+                    ;; Don't follow symlinks.
+                    lstat))
 
 \f
 (with-test-prefix "basic"
@@ -434,3 +469,46 @@
         (set! proc ((load-thunk-from-memory bytecode)))
         (procedure? proc)))
     (pass-if-equal "proc executes" 42 (proc))))
+
+(with-test-prefix "compile-file"
+  ;; Setup test library sources in a temporary directory.
+  (let ((hello-sexp '(define-library (hello)
+                       (import (scheme base)
+                               (scheme write))
+                       (export hello)
+                       (include "hello/hello-impl.scm")))
+        (hello-impl-sexp '(begin
+                            (include "../external/nothing.scm")
+                            (include "body.scm")))
+        (hello-body-sexp '(define (hello)
+                            (display "hello!\n"))))
+    (with-temporary-directory
+     (mkdir "module")
+     (call-with-output-file "module/hello.scm"
+       (cut write hello-sexp <>))
+     (mkdir "module/hello")
+     (call-with-output-file "module/hello/hello-impl.scm"
+       (cut write hello-impl-sexp <>))
+     (call-with-output-file "module/hello/body.scm"
+       (cut write hello-body-sexp <>))
+     (mkdir "module/external")
+     (call-with-output-file "module/external/nothing.scm" (const #t))
+     (mkdir "build")
+     (chdir "build")
+
+     (pass-if "relative include works"
+       (compile-file "../module/hello.scm" #:output-file "hello.go")
+       #t)
+
+     ;; This used to fail, because compile-file's #:canonicalization
+     ;; defaults to 'relative, which caused '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.
+     (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")
+       #t))))
-- 
2.41.0

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."
 
 \f
 
+;;; {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)))))))
+
+\f
+
 ;;; {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

bug#66046: [PATCH v3 1/3] libguile/fports.c: Remove extraneous include.

[Maxim Cournoyer]

* libguile/fports.c: Delete "hashtab.h" include, which is unused.
---

(no changes since v1)

 libguile/fports.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/libguile/fports.c b/libguile/fports.c
index 9d4ca6ace..8f19216b7 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -52,7 +52,6 @@
 #include "fluids.h"
 #include "gc.h"
 #include "gsubr.h"
-#include "hashtab.h"
 #include "keywords.h"
 #include "modules.h"
 #include "numbers.h"

base-commit: d579848cb5d65440af5afd9c8968628665554c22
-- 
2.41.0

bug#66046: [PATCH v3 2/3] tests: Add new compile-file tests.

[Maxim Cournoyer]

Add a test for bug #66046.

To run just the compiler tests:

  ./meta/guile -L test-suite -L . test-suite/tests/compiler.test

* test-suite/tests/compiler.test (with-temporary-directory): New syntax.
(delete-file-recursively): New procedure.
("compile-file: relative include works")
("compile-file: relative include works with load path
canonicalization"): New tests.
---

(no changes since v1)

 test-suite/tests/compiler.test | 82 +++++++++++++++++++++++++++++++++-
 1 file changed, 80 insertions(+), 2 deletions(-)

diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index a018e0c41..79aee1a0e 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
 ;;;; compiler.test --- tests for the compiler      -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021-2022 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-2023 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,15 +18,50 @@
 (define-module (tests compiler)
   #:use-module (test-suite lib)
   #:use-module (test-suite guile-test)
+  #:use-module (ice-9 ftw)
   #:use-module (system base compile)
   #:use-module ((language tree-il)
                 #:select (tree-il-src call-args))
   #:use-module ((system vm loader) #:select (load-thunk-from-memory))
-  #:use-module ((system vm program) #:select (program-sources source:addr)))
+  #:use-module ((system vm program) #:select (program-sources source:addr))
+  #:use-module (srfi srfi-26))
 
 (define read-and-compile
   (@@ (system base compile) read-and-compile))
 
+;;; Based on 'with-directory-excursion', from (guix build utils).
+(define-syntax-rule (with-temporary-directory body ...)
+  "Run BODY with DIR as the process's current directory."
+  (let ((init (getcwd))
+        (dir (mkdtemp "tempdir.XXXXXX")))
+   (dynamic-wind
+     (lambda ()
+       (chdir dir))
+     (lambda ()
+       body ...)
+     (lambda ()
+       (chdir init)
+       (delete-file-recursively dir)))))
+
+;;; XXX: Adapted from (guix build utils).
+(define* (delete-file-recursively dir)
+  "Delete DIR recursively, like `rm -rf', without following symlinks."
+  (file-system-fold (const #t)          ;enter
+                    (lambda (file stat result)   ; leaf
+                      (delete-file file))
+                    (const #t)                   ; down
+                    (lambda (dir stat result)    ; up
+                      (rmdir dir))
+                    (const #t)                   ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port)
+                              "warning: failed to delete ~a: ~a~%"
+                              file (strerror errno)))
+                    #t
+                    dir
+
+                    ;; Don't follow symlinks.
+                    lstat))
 
 \f
 (with-test-prefix "basic"
@@ -434,3 +469,46 @@
         (set! proc ((load-thunk-from-memory bytecode)))
         (procedure? proc)))
     (pass-if-equal "proc executes" 42 (proc))))
+
+(with-test-prefix "compile-file"
+  ;; Setup test library sources in a temporary directory.
+  (let ((hello-sexp '(define-library (hello)
+                       (import (scheme base)
+                               (scheme write))
+                       (export hello)
+                       (include "hello/hello-impl.scm")))
+        (hello-impl-sexp '(begin
+                            (include "../external/nothing.scm")
+                            (include "body.scm")))
+        (hello-body-sexp '(define (hello)
+                            (display "hello!\n"))))
+    (with-temporary-directory
+     (mkdir "module")
+     (call-with-output-file "module/hello.scm"
+       (cut write hello-sexp <>))
+     (mkdir "module/hello")
+     (call-with-output-file "module/hello/hello-impl.scm"
+       (cut write hello-impl-sexp <>))
+     (call-with-output-file "module/hello/body.scm"
+       (cut write hello-body-sexp <>))
+     (mkdir "module/external")
+     (call-with-output-file "module/external/nothing.scm" (const #t))
+     (mkdir "build")
+     (chdir "build")
+
+     (pass-if "relative include works"
+       (compile-file "../module/hello.scm" #:output-file "hello.go")
+       #t)
+
+     ;; This used to fail, because compile-file's #:canonicalization
+     ;; 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
+     ;; '%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")
+       #t))))
-- 
2.41.0

bug#66046: [PATCH v3 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 v3:
 - Move tests hunks to test commit

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 ++----
 3 files changed, 102 insertions(+), 8 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."
 
 \f
 
+;;; {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)))))))
+
+\f
+
 ;;; {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)
-- 
2.41.0