From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Maxim Cournoyer Newsgroups: gmane.lisp.guile.bugs Subject: bug#66046: [PATCH 2/2] ice-9: Fix 'include' when used in compilation contexts. Date: Thu, 9 Nov 2023 22:36:22 -0500 Message-ID: <20231110033627.26468-2-maxim.cournoyer@gmail.com> References: <878r7akwce.fsf@gmail.com> <20231110033627.26468-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="33035"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Timothy Sample , Maxim Cournoyer , Daphne Preston-Kendal To: 66046@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Fri Nov 10 04:37:48 2023 Return-path: Envelope-to: guile-bugs@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 ) id 1r1IL5-0008QN-Jg for guile-bugs@m.gmane-mx.org; Fri, 10 Nov 2023 04:37:47 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1r1IKh-000326-TY; Thu, 09 Nov 2023 22:37:23 -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 ) id 1r1IKg-00031c-NF for bug-guile@gnu.org; Thu, 09 Nov 2023 22:37:22 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1r1IKg-0005Hz-Ez for bug-guile@gnu.org; Thu, 09 Nov 2023 22:37:22 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1r1ILJ-0007ez-Ma for bug-guile@gnu.org; Thu, 09 Nov 2023 22:38:01 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Maxim Cournoyer Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Fri, 10 Nov 2023 03:38:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 66046 X-GNU-PR-Package: guile Original-Received: via spool by 66046-submit@debbugs.gnu.org id=B66046.169958744629385 (code B ref 66046); Fri, 10 Nov 2023 03:38:01 +0000 Original-Received: (at 66046) by debbugs.gnu.org; 10 Nov 2023 03:37:26 +0000 Original-Received: from localhost ([127.0.0.1]:49260 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r1IKk-0007ds-80 for submit@debbugs.gnu.org; Thu, 09 Nov 2023 22:37:26 -0500 Original-Received: from mail-qk1-x72b.google.com ([2607:f8b0:4864:20::72b]:50479) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1r1IKg-0007dY-8Z for 66046@debbugs.gnu.org; Thu, 09 Nov 2023 22:37:24 -0500 Original-Received: by mail-qk1-x72b.google.com with SMTP id af79cd13be357-779f2718accso106047585a.1 for <66046@debbugs.gnu.org>; Thu, 09 Nov 2023 19:36:42 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1699587397; x=1700192197; darn=debbugs.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=iE/mKy0/M6yEFXJsBzicKTjFYJ4/+Xd4Y/9wy6kEwVE=; b=SZSE9UH4+GBzLR6rDUwJE3YwtCmK5xvCafqxOCmVgUNuXvwbC9n/CFksyNuvV1qJj1 U3bA/ZdZkurk/l6ljeAKSVy0bpUDBtbzBjGfdBcFURISIkG1hw3XJrsGr11jCE5lX5H0 ZdOEH2D0JGvoIhLR6tQv64n/1pSjgg3A7To8iaC94EPF3XvQFqgLBHYyalhZiZ7oK3XI Cg8xXuhGXRKyb8tuDnUkrFE/Byzu2ZRKxF6NvZt7OpF/DONPl/cjHfnX2RVTgs/AMgmG SVZeMiY43Ypcy/+eIZ5hKfPkL4T5ZeKrStT9oQEP5odAs5TI27i/aKhcvOeqTqeTwuLc DNSQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1699587397; x=1700192197; 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=iE/mKy0/M6yEFXJsBzicKTjFYJ4/+Xd4Y/9wy6kEwVE=; b=kVpsoVmc+XNoff7ZrrrrmIuKUJ6tYdY9isdXkGnLHntLrLfoEPo2223vQi5esNxpUq qHdpPV+wxnsJedxhRkecKVY8/E3SaTqTI0u8CoPUpndl6MERFUja3qJUDzXiZ5hoyyAO SZrXa1pXbbDVh/DcUr3O2InKx6hSAY9dJNFaQttYo7CEhlw12gUA+mKms1eHUuk4gYck 80qFZNt9ThAWIQTfUYxhuPr+ljZfF2bR8Ver0ype43PdqSlbq1TlVtxne/5+Df9TJlXq dFR7XANSymr3EodKTPEHA3B0+N3md6EEYI8U0LFqA6YfwvYuHa/UPOzR8ruX2wUy4bWe iJiw== X-Gm-Message-State: AOJu0YwI6e1+JXHndz0po6+QlX4F6od6xme2zSX6s/8Sa0bwDj1uDxlM SB2dkFJATskMKjoetnl7AHz0GKmXp4o= X-Google-Smtp-Source: AGHT+IEJZYocBr8SE43FXBmsEfPp+Sy82kBYLOk4EU7MXYjz9T3FeYdQ8Wjzd6uKLs0BXIZRS5LlVg== X-Received: by 2002:a05:6214:40d:b0:66d:2aa3:cd49 with SMTP id z13-20020a056214040d00b0066d2aa3cd49mr6368233qvx.14.1699587396835; Thu, 09 Nov 2023 19:36:36 -0800 (PST) Original-Received: from localhost.localdomain (dsl-10-129-91.b2b2c.ca. [72.10.129.91]) by smtp.gmail.com with ESMTPSA id mn11-20020a0562145ecb00b0065aff6b49afsm2609967qvb.110.2023.11.09.19.36.36 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 09 Nov 2023 19:36:36 -0800 (PST) X-Mailer: git-send-email 2.41.0 In-Reply-To: <20231110033627.26468-1-maxim.cournoyer@gmail.com> X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.bugs:10691 Archived-At: 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