From: Harald Anlauf <anlauf@gmx.de>
Date: Mon, 11 Mar 2024 21:05:51 +0000 (+0100)
Subject: Fortran: handle procedure pointer component in DT array [PR110826]
X-Git-Tag: releases/gcc-13.3.0~336
X-Git-Url: https://gcc.gnu.org/git/?a=commitdiff_plain;h=4e9f475cdc8617f94c903656faaf28910c21c29b;p=gcc.git

Fortran: handle procedure pointer component in DT array [PR110826]

gcc/fortran/ChangeLog:

	PR fortran/110826
	* array.cc (gfc_array_dimen_size): When walking the ref chain of an
	array and the ultimate component is a procedure pointer, do not try
	to figure out its dimension even if it is a array-valued function.

gcc/testsuite/ChangeLog:

	PR fortran/110826
	* gfortran.dg/proc_ptr_comp_53.f90: New test.

(cherry picked from commit 81ee1298b47d3f3b3712ef3f3b2929ca26c4bcd2)
---

diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index be5eb8b6a0f6..936f774353ee 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -2600,6 +2600,13 @@ gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
     case EXPR_FUNCTION:
       for (ref = array->ref; ref; ref = ref->next)
 	{
+	  /* Ultimate component is a procedure pointer.  */
+	  if (ref->type == REF_COMPONENT
+	      && !ref->next
+	      && ref->u.c.component->attr.function
+	      && IS_PROC_POINTER (ref->u.c.component))
+	    return false;
+
 	  if (ref->type != REF_ARRAY)
 	    continue;
 
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
new file mode 100644
index 000000000000..affb59222351
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_53.f90
@@ -0,0 +1,43 @@
+! { dg-do compile }
+! PR fortran/110826 - procedure pointer component in DT array
+
+module m
+  implicit none
+
+  type pp
+    procedure(func_template), pointer, nopass :: f =>null()
+  end type pp
+
+  abstract interface
+     function func_template(state) result(dstate)
+       implicit none
+       real, dimension(:,:), intent(in)              :: state
+       real, dimension(size(state,1), size(state,2)) :: dstate
+     end function
+  end interface
+
+contains
+
+  function zero_state(state) result(dstate)
+    real, dimension(:,:), intent(in)              :: state
+    real, dimension(size(state,1), size(state,2)) :: dstate
+    dstate = 0.
+  end function zero_state
+
+end module m
+
+program test_func_array
+  use m
+  implicit none
+
+  real, dimension(4,6) :: state
+  type(pp) :: func_scalar
+  type(pp) :: func_array(4)
+
+  func_scalar  %f => zero_state
+  func_array(1)%f => zero_state
+  print *, func_scalar  %f(state)
+  print *, func_array(1)%f(state)
+  if (.not. all (shape (func_scalar  %f(state)) == shape (state))) stop 1
+  if (.not. all (shape (func_array(1)%f(state)) == shape (state))) stop 2
+end program test_func_array