From 8f535b19bd0cb6a7c99ac9ba4c07778f86698a1c Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Tue, 12 Mar 2024 22:58:39 +0100
Subject: [PATCH] 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.
---
 gcc/fortran/expr.cc                           | 19 ++---
 gcc/testsuite/gfortran.dg/is_contiguous_4.f90 | 81 +++++++++++++++++++
 2 files changed, 91 insertions(+), 9 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/is_contiguous_4.f90

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 37ea95d0185..82a642b01f7 100644
--- 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
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
--
2.35.3