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

[Maxim Cournoyer]

Hello,

Here's a new test that reproduces the issue:

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

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