From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: 66046@debbugs.gnu.org
Cc: Timothy Sample <samplet@ngyro.com>,
Amirouche <amirouche@hyper.dev>,
Maxim Cournoyer <maxim.cournoyer@gmail.com>,
Daphne Preston-Kendal <dpk@nonceword.org>
Subject: bug#66046: [PATCH v3 3/3] ice-9: Fix 'include' when used in compilation contexts.
Date: Wed, 22 Nov 2023 11:17:52 -0500 [thread overview]
Message-ID: <20231122161801.32398-3-maxim.cournoyer@gmail.com> (raw)
In-Reply-To: <20231122161801.32398-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.
---
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
prev parent reply other threads:[~2023-11-22 16:17 UTC|newest]
Thread overview: 16+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-09-17 8:22 bug#66046: Relative includes in R7RS define-library seem broken Daphne Preston-Kendal
2023-11-06 18:31 ` Timothy Sample
2023-11-06 18:48 ` Maxim Cournoyer
2023-11-06 19:57 ` Maxim Cournoyer
2023-11-07 4:42 ` Maxim Cournoyer
2023-11-10 3:36 ` bug#66046: [PATCH 1/2] tests: Add new compile-file tests Maxim Cournoyer
2023-11-10 3:36 ` bug#66046: [PATCH 2/2] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-11-11 11:58 ` bug#66046: Relative includes in R7RS define-library seem broken Amirouche
2023-11-14 13:57 ` Maxim Cournoyer
2023-11-18 22:56 ` Maxim Cournoyer
2023-11-22 16:11 ` bug#66046: [PATCH v2 1/3] libguile/fports.c: Remove extraneous include Maxim Cournoyer
2023-11-22 16:11 ` bug#66046: [PATCH v2 2/3] tests: Add new compile-file tests Maxim Cournoyer
2023-11-22 16:11 ` bug#66046: [PATCH v2 3/3] ice-9: Fix 'include' when used in compilation contexts Maxim Cournoyer
2023-11-22 16:17 ` bug#66046: [PATCH v3 1/3] libguile/fports.c: Remove extraneous include Maxim Cournoyer
2023-11-22 16:17 ` bug#66046: [PATCH v3 2/3] tests: Add new compile-file tests Maxim Cournoyer
2023-11-22 16:17 ` Maxim Cournoyer [this message]
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=20231122161801.32398-3-maxim.cournoyer@gmail.com \
--to=maxim.cournoyer@gmail.com \
--cc=66046@debbugs.gnu.org \
--cc=amirouche@hyper.dev \
--cc=dpk@nonceword.org \
--cc=samplet@ngyro.com \
/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).