[gcc r15-7389] Fortran: FIx ICE in associate with elemental function [PR118750]

[Paul Thomas via Gcc-cvs]

https://gcc.gnu.org/g:a03303b4d5b2ca58e5750a4d5bd735d85a091273

commit r15-7389-ga03303b4d5b2ca58e5750a4d5bd735d85a091273
Author: Paul Thomas <pa...@gcc.gnu.org>
Date:   Thu Feb 6 16:40:19 2025 +0000

    Fortran:  FIx ICE in associate with elemental function [PR118750]
    
    2025-02-06  Paul Thomas  <pa...@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.

Diff:
---
 gcc/fortran/resolve.cc                     |  2 +-
 gcc/testsuite/gfortran.dg/associate_72.f90 | 26 ++++++++++++++++++++++++++
 2 files changed, 27 insertions(+), 1 deletion(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index c9736db908fe..7adbf958aec1 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10728,7 +10728,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
index 000000000000..993ebdfd5a7e
--- /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" } }