Dear all,
the attached simple patch fixes a (9+) regression for passing
to a CONTIGUOUS,TARGET dummy an *effective argument* that is
contiguous, although the actual argument is not simply-contiguous
(it is a pointer without the CONTIGOUS attribute in the PR).
Since a previous attempt for a patch lead to regressions in
gfortran.dg/bind-c-contiguous-3.f90, which is rather dense,
I decided to enhance the current testcase with various
combinations of actual and dummy arguments that allow to
study whether a _gfortran_internal_pack is generated in
places where we want to. (_gfortran_internal_pack does not
create a temporary when no packing is needed).
Regtested on x86_64-pc-linux-gnu. OK for mainline?
I would like to backport this - after a grace period - to
at least 13-branch. Any objections here?
Thanks,
Harald
From d8765bd669e501781672c0bec976b2f5fd7acff6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf
Date: Sat, 16 Dec 2023 19:14:55 +0100
Subject: [PATCH] Fortran: fix argument passing to CONTIGUOUS,TARGET dummy
[PR97592]
gcc/fortran/ChangeLog:
PR fortran/97592
* trans-expr.cc (gfc_conv_procedure_call): For a contiguous dummy
with the TARGET attribute, the effective argument may still be
contiguous even if the actual argument is not simply-contiguous.
Allow packing to be decided at runtime by _gfortran_internal_pack.
gcc/testsuite/ChangeLog:
PR fortran/97592
* gfortran.dg/contiguous_15.f90: New test.
---
gcc/fortran/trans-expr.cc | 4 +-
gcc/testsuite/gfortran.dg/contiguous_15.f90 | 234
2 files changed, 237 insertions(+), 1 deletion(-)
create mode 100644 gcc/testsuite/gfortran.dg/contiguous_15.f90
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f4185db5b7f..218fede6a82 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7124,7 +7124,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
INTENT_IN, fsym->attr.pointer);
}
else if (fsym && fsym->attr.contiguous
- && !gfc_is_simply_contiguous (e, false, true)
+ && (fsym->attr.target
+ ? gfc_is_not_contiguous (e)
+ : !gfc_is_simply_contiguous (e, false, true))
&& gfc_expr_is_variable (e))
{
gfc_conv_subref_array_arg (, e, nodesc_arg,
diff --git a/gcc/testsuite/gfortran.dg/contiguous_15.f90 b/gcc/testsuite/gfortran.dg/contiguous_15.f90
new file mode 100644
index 000..424eb080fd1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_15.f90
@@ -0,0 +1,234 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/97592 - fix argument passing to CONTIGUOUS,TARGET dummy
+!
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(_2d" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(" 3 "original" } }
+!
+! N.B.: there is no reliable count of _gfortran_internal_pack on temporaries parm.*
+
+program pr97592
+ implicit none
+ integer :: i, k
+ integer, target :: a(10)
+ integer, pointer :: p1(:), p2(:), tgt(:), expect(:)
+ integer, pointer, contiguous :: cp(:)
+ integer, allocatable, target :: b(:)
+
+ !--
+ ! Code from original PR
+ !--
+ call RemappingTest ()
+
+ !-
+ ! Additional 1-d tests
+ !-
+ a = [(i, i=1,size(a))]
+ b = a
+
+ ! Set p1 to an actually contiguous pointer
+ p1(13:) => a(3::2)
+ print *, lbound (p1), ubound (p1), is_contiguous (p1)
+
+ ! non-contiguous pointer actual argument
+ expect => p1
+ call chk_cont (p1)
+
+ expect => p1
+ call chk_tgt_cont (p1)
+
+ expect => p1
+ call chk_ptr (p1, p2)
+ if (any (p2 /= p1)) stop 1
+
+ expect => p1
+ call chk_tgt (p1, p2)
+ if (any (p2 /= p1)) stop 2
+
+ ! non-contiguous target actual argument
+ expect => b(3::2)
+ call chk_tgt_cont (b(3::2))
+
+ expect => b(3::2)
+ call chk_tgt (b(3::2), p2)
+ if (any (p2 /= p1)) stop 3
+
+ expect => b(3::2)
+ call chk_ptr (b(3::2), p2)
+ if (any (p2 /= p1)) stop 4
+
+ ! Set p1 to an actually contiguous pointer
+ cp(17:) => a(3:9:1)
+ p1 => cp
+ print *, lbound (cp), ubound (cp), is_contiguous (cp)
+ print *, lbound (p1), ubound (p1), is_contiguous (p1)
+
+ expect => p1
+ call chk_tgt (p1, p2)
+ if (any (p2 /= cp)) stop 31
+
+ expect => cp
+ call chk_tgt (cp, p2)
+ if (any (p2 /= cp)) stop 32
+
+ expect => cp
+ call chk_tgt_cont (cp, p2)
+ if (any (p2 /= cp)) stop 33
+
+ expect => cp
+ call chk_tgt_expl (cp, p2, size (cp))
+ if (any (p2 /= cp)) stop 34
+
+ ! See F2018:15.5.2.4 and F2018:C.10.4
+ expect => p1
+ call chk_tgt_cont (p1, p2)
+! print *, p2
+ if (any (p2 /= cp)) stop 35
+
+ expect => p1
+ call chk_tgt_expl (p1, p2, size (p1))
+ if (any (p2 /= cp)) stop 36
+
+ expect => cp
+ call chk_ptr_cont (
