[gcc r13-8468] Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
Harald Anlauf
anlauf@gcc.gnu.org
Tue Mar 19 19:21:53 GMT 2024
https://gcc.gnu.org/g:5b928badac560ad48e0e9fc480096ff396d9d9c6
commit r13-8468-g5b928badac560ad48e0e9fc480096ff396d9d9c6
Author: Harald Anlauf <anlauf@gmx.de>
Date: Tue Mar 12 22:58:39 2024 +0100
Fortran: fix IS_CONTIGUOUS for polymorphic dummy arguments [PR114001]
gcc/fortran/ChangeLog:
PR fortran/114001
* expr.cc (gfc_is_simply_contiguous): Adjust logic so that CLASS
symbols are also handled.
gcc/testsuite/ChangeLog:
PR fortran/114001
* gfortran.dg/is_contiguous_4.f90: New test.
(cherry picked from commit 11caf47b599568c6c6f5a12cf8e21f50778176d3)
Diff:
---
gcc/fortran/expr.cc | 19 ++++---
gcc/testsuite/gfortran.dg/is_contiguous_4.f90 | 81 +++++++++++++++++++++++++++
2 files changed, 91 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 9fdbe7a84c5..8b9c93940c8 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5994,15 +5994,16 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
}
sym = expr->symtree->n.sym;
- if (expr->ts.type != BT_CLASS
- && ((part_ref
- && !part_ref->u.c.component->attr.contiguous
- && part_ref->u.c.component->attr.pointer)
- || (!part_ref
- && !sym->attr.contiguous
- && (sym->attr.pointer
- || (sym->as && sym->as->type == AS_ASSUMED_RANK)
- || (sym->as && sym->as->type == AS_ASSUMED_SHAPE)))))
+ if ((part_ref
+ && part_ref->u.c.component
+ && !part_ref->u.c.component->attr.contiguous
+ && IS_POINTER (part_ref->u.c.component))
+ || (!part_ref
+ && expr->ts.type != BT_CLASS
+ && !sym->attr.contiguous
+ && (sym->attr.pointer
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK)
+ || (sym->as && sym->as->type == AS_ASSUMED_SHAPE))))
return false;
if (!ar || ar->type == AR_FULL)
diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_4.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
new file mode 100644
index 00000000000..cb066f8836b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/is_contiguous_4.f90
@@ -0,0 +1,81 @@
+! { dg-do run }
+! PR fortran/114001 - IS_CONTIGUOUS and polymorphic dummy
+
+program main
+ implicit none
+ integer :: i, cnt = 0
+ logical :: expect
+ integer, target :: m(10) = [(i,i=1,size(m))]
+ integer, pointer :: p(:)
+ type t
+ integer :: j
+ end type t
+ type(t), pointer :: tt(:), tp(:) ! Type pointer
+ class(t), pointer :: ct(:), cp(:) ! Class pointer
+
+ p => m(1:3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (.not. expect) stop 91
+ call sub_star (p, expect)
+ p => m(1::3)
+ expect = is_contiguous (p)
+ print *, "is_contiguous (p)=", expect
+ if (expect) stop 92
+ call sub_star (p, expect)
+
+ allocate (tt(10))
+ tt(:)% j = m
+ tp => tt(4:6)
+ expect = is_contiguous (tp)
+ if (.not. expect) stop 96
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+ tp => tt(4::3)
+ expect = is_contiguous (tp)
+ if (expect) stop 97
+ print *, "is_contiguous (tp)=", expect
+ call sub_t (tp, expect)
+
+ allocate (ct(10))
+ ct(:)% j = m
+ cp => ct(7:9)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (.not. expect) stop 98
+ call sub_t (cp, expect)
+ cp => ct(4::3)
+ expect = is_contiguous (cp)
+ print *, "is_contiguous (cp)=", expect
+ if (expect) stop 99
+ call sub_t (cp, expect)
+
+contains
+
+ subroutine sub_star (x, expect)
+ class(*), intent(in) :: x(:)
+ logical, intent(in) :: expect
+ cnt = cnt + 10
+ if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(1): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 1)
+ end if
+ select type (x)
+ type is (integer)
+ if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_star(2): is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 2)
+ end if
+ end select
+ end
+
+ subroutine sub_t (x, expect)
+ class(t), intent(in) :: x(:)
+ logical, intent(in) :: expect
+ cnt = cnt + 10
+ if (is_contiguous (x) .neqv. expect) then
+ print *, "sub_t: is_contiguous (x)=", is_contiguous (x), expect
+ stop (cnt + 3)
+ end if
+ end
+end
More information about the Gcc-cvs
mailing list