From d8765bd669e501781672c0bec976b2f5fd7acff6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
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
@@ -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 (&parmse, e, nodesc_arg,
new file mode 100644
@@ -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 \\(&b_2d" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&p1" 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 (cp, p2)
+ if (any (p2 /= cp)) stop 37
+
+ ! Pass array section which is actually contigous
+ k = 1
+ expect => cp(::k)
+ call chk_ptr (cp(::k), p2)
+ if (any (p2 /= cp(::k))) stop 38
+
+ expect => p1(::k)
+ call chk_tgt_cont (p1(::k), p2)
+ if (any (p2 /= p1(::k))) stop 39
+
+ expect => p1(::k)
+ call chk_tgt (p1(::k), p2)
+ if (any (p2 /= p1(::k))) stop 40
+
+ expect => p1(::k)
+ call chk_tgt_expl (p1(::k), p2, size (p1(::k)))
+ if (any (p2 /= p1(::k))) stop 41
+
+ expect => b(3::k)
+ call chk_tgt_cont (b(3::k), p2)
+ if (any (p2 /= b(3::k))) stop 42
+
+ expect => b(3::k)
+ call chk_tgt (b(3::k), p2)
+ if (any (p2 /= b(3::k))) stop 43
+
+ expect => b(3::k)
+ call chk_tgt_expl (b(3::k), p2, size (b(3::k)))
+ if (any (p2 /= b(3::k))) stop 44
+
+ if (any (a /= [(i, i=1,size(a))])) stop 66
+ if (any (a /= b)) stop 77
+ deallocate (b)
+
+contains
+ ! Contiguous pointer dummy
+ subroutine chk_ptr_cont (x, y)
+ integer, contiguous, pointer, intent(in) :: x(:)
+ integer, pointer, optional :: y(:)
+ print *, lbound (x), ubound (x)
+ if (present (y)) y => x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 10
+ if (any (x /= expect)) stop 11
+ if (lbound(expect,1) /= 1 .and. &
+ lbound(expect,1) /= lbound (x,1)) stop 20
+ end if
+ end
+
+ ! Pointer dummy
+ subroutine chk_ptr (x, y)
+ integer, pointer, intent(in) :: x(:)
+ integer, pointer, optional :: y(:)
+ print *, lbound (x), ubound (x)
+ if (present (y)) y => x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 12
+ if (any (x /= expect)) stop 13
+ if (lbound(expect,1) /= 1 .and. &
+ lbound(expect,1) /= lbound (x,1)) stop 22
+ end if
+ end
+
+ ! Dummy with target attribute
+ subroutine chk_tgt_cont (x, y)
+ integer, contiguous, target, intent(in) :: x(:)
+ integer, pointer, optional :: y(:)
+ if (present (y)) y => x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 14
+ if (any (x /= expect)) stop 15
+ end if
+ end
+
+ subroutine chk_tgt (x, y)
+ integer, target, intent(in) :: x(:)
+ integer, pointer, optional :: y(:)
+ if (present (y)) y => x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 16
+ if (any (x /= expect)) stop 17
+ end if
+ end
+
+ ! Explicit-shape dummy with target attribute
+ subroutine chk_tgt_expl (x, y, n)
+ integer, intent(in) :: n
+ integer, target, intent(in) :: x(n)
+ integer, pointer, optional :: y(:)
+ if (present (y)) y => x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 18
+ if (any (x /= expect)) stop 19
+ end if
+ end
+
+ ! Dummy without pointer or target attribute
+ subroutine chk_cont (x)
+ integer, contiguous, intent(in) :: x(:)
+ if (associated (expect)) then
+ if (size (x) /= size (expect)) stop 23
+ if (any (x /= expect)) stop 24
+ end if
+ end
+
+ !------------------------------------------------------------------------
+
+ subroutine RemappingTest ()
+ real, pointer :: B_2D(:,:)
+ real, pointer :: B_3D(:,:,:) => NULL()
+ integer, parameter :: n1=4, n2=4, n3=3
+ !-- Prepare B_2D
+ allocate (B_2D(n1*n2, n3))
+ B_2D = - huge (1.0)
+ if (.not. is_contiguous (B_2D)) stop 101
+ !-- Point B_3D to Storage
+ call SetPointer (B_2D, n1, n2, n3, B_3D)
+ !print *,"is_contiguous (B_3D) =", is_contiguous (B_3D)
+ if (.not. is_contiguous (B_3D)) stop 102
+ !-- Set B_3D
+ B_3D = 2.0
+ !-- See if the result is reflected in Storage
+ if (any (B_2D /= 2.0)) then
+ print *, "B_2D = ", B_2D !-- expect 2.0 for all elements
+ stop 103
+ end if
+ print *,"RemappingTest passed"
+ end
+
+ subroutine SetPointer (C_2D, n1, n2, n3, C_3D)
+ integer, intent(in) :: n1, n2, n3
+ real, target, contiguous :: C_2D(:,:)
+ real, pointer :: C_3D(:,:,:)
+ intent(in) :: C_2D
+ C_3D(1:n1,1:n2,1:n3) => C_2D
+ end
+
+end
--
2.35.3