From mboxrd@z Thu Jan  1 00:00:00 1970
Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Newsgroups: gmane.lisp.guile.devel
Subject: [PATCH v3 3/6] ice-9: Fix 'include' when used in compilation contexts.
Date: Sat, 18 Nov 2023 01:05:35 -0500
Message-ID: <20231118060621.24675-3-maxim.cournoyer@gmail.com>
References: <20231118060621.24675-1-maxim.cournoyer@gmail.com>
Mime-Version: 1.0
Content-Transfer-Encoding: 8bit
Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214";
	logging-data="30685"; mail-complaints-to="usenet@ciao.gmane.io"
Cc: Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Sat Nov 18 07:07:05 2023
Return-path: <guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org>
Envelope-to: guile-devel@m.gmane-mx.org
Original-Received: from lists.gnu.org ([209.51.188.17])
	by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
	(Exim 4.92)
	(envelope-from <guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org>)
	id 1r4ETw-0007r5-Ci
	for guile-devel@m.gmane-mx.org; Sat, 18 Nov 2023 07:07:04 +0100
Original-Received: from localhost ([::1] helo=lists1p.gnu.org)
	by lists.gnu.org with esmtp (Exim 4.90_1)
	(envelope-from <guile-devel-bounces@gnu.org>)
	id 1r4ETS-0006yR-Eq; Sat, 18 Nov 2023 01:06:34 -0500
Original-Received: from eggs.gnu.org ([2001:470:142:3::10])
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <maxim.cournoyer@gmail.com>)
 id 1r4ETQ-0006xw-Sr
 for guile-devel@gnu.org; Sat, 18 Nov 2023 01:06:32 -0500
Original-Received: from mail-qt1-x82e.google.com ([2607:f8b0:4864:20::82e])
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128)
 (Exim 4.90_1) (envelope-from <maxim.cournoyer@gmail.com>)
 id 1r4ETP-000064-1J
 for guile-devel@gnu.org; Sat, 18 Nov 2023 01:06:32 -0500
Original-Received: by mail-qt1-x82e.google.com with SMTP id
 d75a77b69052e-41cc535cd5cso14966601cf.2
 for <guile-devel@gnu.org>; Fri, 17 Nov 2023 22:06:30 -0800 (PST)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=gmail.com; s=20230601; t=1700287589; x=1700892389; darn=gnu.org;
 h=content-transfer-encoding:mime-version:references:in-reply-to
 :message-id:date:subject:cc:to:from:from:to:cc:subject:date
 :message-id:reply-to;
 bh=esXzp4Mn+PyPBkjxD7yiVELfej7KDCTMOEjtDr9T4ag=;
 b=QkrJqj8snV8RKHZL3+MY22xlUxC/e7jO2C0OWWFkTeP1gKS4P3AHKMMR6PbSjkVuln
 STWB4PF1YAY92sxjTymbA3/DfNPI2syMIFd+VCRTZVPeUiY69sb06ANRRcOfXYeeJ02l
 LEbus5+TpyQGS6uLSVqfUw5U0pRbfZZq+QQWXxvMkUSuyZ359RIIvyPbnEvYYfNOt2gV
 S1+Zix99zlyI3WTiFPtfEw1Q2LjOH1mDi4OarUMUZ/CIgnixgobSrN1OQavqwurqhcbl
 vjFiTjmyhX0bGU+LPCVWCr87kQUnRTthDRTtQTYAuZVcpuTzHVXkmJBgnuR9BSe1YXcw
 PN7A==
X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=1e100.net; s=20230601; t=1700287589; x=1700892389;
 h=content-transfer-encoding:mime-version:references:in-reply-to
 :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc
 :subject:date:message-id:reply-to;
 bh=esXzp4Mn+PyPBkjxD7yiVELfej7KDCTMOEjtDr9T4ag=;
 b=jPzXffij+iqHeNL9WmHHalanpPkE5EMgIVBzID3VTHUJtPWMWd/X2i7RHuJSzEalWf
 6odY5aq9WRovyg9+OUu71eMo9fsZFP6mGUZ0Rvniv7LQ+8pAvthGiNVRGTrR96pFpnHT
 Gr4plb7I1rdg9bBaUWZNR2T4mqxD2UtJCTeZJuAihCKVfpZqbl5hwsl70k/TqxAivrea
 hcxdruPpLbyhKjS8/JnKDsZVtU6NDOrqKLElBIW/Ri0uPSWhdwoSrnOry1+AX6CU23NH
 0MZpomdOKm8Hw2VHVRsC6X2iZMco+NNgjrd7mmWOZwXrE0dZukiLGMO8syik1nscSxSa
 ojyg==
X-Gm-Message-State: AOJu0Yztr7c4LA5IDBgMrECmt6U7iul46BOIeT5fu3wI+tnmdcLOkymH
 AmdNwrXxNSZ/GQ2aiexMO5oFUTkoK4U=
X-Google-Smtp-Source: AGHT+IE9umN9DCWraTg3daWNcRcL2WoBub8GnOsE//efn8waMFd0Kg0C446eeYHNSssMOw7hSG6w3w==
X-Received: by 2002:ac8:5f4f:0:b0:41e:2d77:c727 with SMTP id
 y15-20020ac85f4f000000b0041e2d77c727mr2406812qta.29.1700287589508; 
 Fri, 17 Nov 2023 22:06:29 -0800 (PST)
Original-Received: from localhost.localdomain (dsl-154-55.b2b2c.ca. [66.158.154.55])
 by smtp.gmail.com with ESMTPSA id
 m9-20020a0ce6e9000000b00677a12f11bcsm1179262qvn.24.2023.11.17.22.06.28
 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256);
 Fri, 17 Nov 2023 22:06:29 -0800 (PST)
X-Mailer: git-send-email 2.41.0
In-Reply-To: <20231118060621.24675-1-maxim.cournoyer@gmail.com>
Received-SPF: pass client-ip=2607:f8b0:4864:20::82e;
 envelope-from=maxim.cournoyer@gmail.com; helo=mail-qt1-x82e.google.com
X-Spam_score_int: -20
X-Spam_score: -2.1
X-Spam_bar: --
X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
 DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001,
 RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001,
 T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-BeenThere: guile-devel@gnu.org
X-Mailman-Version: 2.1.29
Precedence: list
List-Id: "Developers list for Guile,
 the GNU extensibility library" <guile-devel.gnu.org>
List-Unsubscribe: <https://lists.gnu.org/mailman/options/guile-devel>,
 <mailto:guile-devel-request@gnu.org?subject=unsubscribe>
List-Archive: <https://lists.gnu.org/archive/html/guile-devel>
List-Post: <mailto:guile-devel@gnu.org>
List-Help: <mailto:guile-devel-request@gnu.org?subject=help>
List-Subscribe: <https://lists.gnu.org/mailman/listinfo/guile-devel>,
 <mailto:guile-devel-request@gnu.org?subject=subscribe>
Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org
Original-Sender: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org
Xref: news.gmane.io gmane.lisp.guile.devel:22085
Archived-At: <http://permalink.gmane.org/gmane.lisp.guile.devel/22085>

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

(no changes since v1)

 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