From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Subject: [PATCH v7 01/16] ice-9: Fix 'include' when used in compilation contexts.
Date: Mon, 4 Dec 2023 16:45:06 -0500 [thread overview]
Message-ID: <20231204215143.3146-2-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231204215143.3146-1-maxim.cournoyer@gmail.com>
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.
* NEWS: Mention bug fix.
---
(no changes since v1)
NEWS | 3 ++
libguile/fports.c | 41 +++++++++++++++++++++++++--
module/ice-9/boot-9.scm | 61 ++++++++++++++++++++++++++++++++++++++++
module/ice-9/psyntax.scm | 8 ++----
4 files changed, 105 insertions(+), 8 deletions(-)
diff --git a/NEWS b/NEWS
index b319404d7..6676c5715 100644
--- a/NEWS
+++ b/NEWS
@@ -48,6 +48,9 @@ a buffer overrun, and so might vary. This problem affected a number of
other operations, given the internal use of those functions.
+** Fix 'include' not finding included files when byte compiling Guile
+ (<https://bugs.gnu.org/66046>)
+
\f
Changes in 3.0.9 (since 3.0.8)
diff --git a/libguile/fports.c b/libguile/fports.c
index 9d4ca6ace..419e9ee3f 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"
@@ -60,6 +61,7 @@
#include "ports-internal.h"
#include "posix.h"
#include "read.h"
+#include "srfi-13.h"
#include "strings.h"
#include "symbols.h"
#include "syscalls.h"
@@ -124,6 +126,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;
@@ -144,7 +147,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))
{
@@ -767,4 +797,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
next prev parent reply other threads:[~2023-12-04 21:45 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-12-04 21:45 [PATCH v7 00/16] Add SRFI 209 and dependencies; improve support for R7RS libraries Maxim Cournoyer
2023-12-04 21:45 ` Maxim Cournoyer [this message]
2023-12-04 21:45 ` [PATCH v7 02/16] Use R7RS 'rename' syntax for exports Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 03/16] r7rs-libraries: Add support for 'else' clause in cond-expand Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 04/16] r7rs-libraries: Better support R7RS SRFI library names Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 05/16] (scheme base): Support non-negative SRFI integer names in cond-expand Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 06/16] Share features tested by cond-expand library declarations and expressions Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 07/16] build: Register '.sld' as an alternative extension to '.scm' Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 08/16] module: Add SRFI 126 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 09/16] module: Add SRFI 128 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 10/16] module: Add (scheme comparator) Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 11/16] module: Add (scheme sort) Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 12/16] module: Add SRFI 125 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 13/16] module: Add SRFI 151 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 14/16] module: Add SRFI 160 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 15/16] module: Add SRFI 178 Maxim Cournoyer
2023-12-04 21:45 ` [PATCH v7 16/16] module: Add SRFI 209 Maxim Cournoyer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20231204215143.3146-2-maxim.cournoyer@gmail.com \
--to=maxim.cournoyer@gmail.com \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).