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.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 37ea95d0185cf9f1a8190f9acf649c9b9e58fbea..82a642b01f7a6f593a67aafb47fc03a3709a9029 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6025,15 +6025,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 (file)
index 0000000..cb066f8
--- /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