Fortran: FIx ICE in associate with elemental function [PR118750]

2025-02-06  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/118750
	* resolve.cc (resolve_assoc_var): If the target expression has
	a rank, do not use gfc_expression_rank, since it will return 0
	if the function is elemental. Resolution will have produced the
	correct rank.

gcc/testsuite/
	PR fortran/118750
	* gfortran.dg/associate_72.f90: New test.

(cherry picked from commit a03303b4d5b2ca58e5750a4d5bd735d85a091273)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4d5e8b5537ab8f4a3330c471d87c20ad211a7c92..a0ed0e516da349db22dc6054fd67c95f724fd668 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9547,7 +9547,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
                          || gfc_is_ptr_fcn (target));
 
   /* Finally resolve if this is an array or not.  */
-  if (target->expr_type == EXPR_FUNCTION
+  if (target->expr_type == EXPR_FUNCTION && target->rank == 0
       && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED))
     {
       gfc_expression_rank (target);

diff --git a/gcc/testsuite/gfortran.dg/associate_72.f90 b/gcc/testsuite/gfortran.dg/associate_72.f90
new file mode 100644 (file)
index 0000000..993ebdf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_72.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for the 14/15 regression PR118750
+!
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+!
+  implicit none
+
+  type string_t
+    character(:), allocatable :: str
+  end type
+
+  associate(str_a => get_string([string_t ("abcd"),string_t ("ef")]))
+    if (str_a(1)%str//str_a(2)%str /= "abcdef") STOP 1 ! Returned "Invalid array reference at (1)"
+  end associate
+
+contains
+
+  type(string_t) elemental function get_string(mold)
+    class(string_t), intent(in) :: mold
+    get_string = string_t(mold%str)
+  end function
+
+end 
+! { dg-final { scan-tree-dump-times "array01_string_t str_a" 1 "original" } }