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 (&parmse, 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 00000000000..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 \\(&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