Fortran: Fix select type regression due to r14-9489 [PR114874]

2024-05-17  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/114874
	* gfortran.h: Add 'assoc_name_inferred' to gfc_namespace.
	* match.cc (gfc_match_select_type): Set 'assoc_name_inferred'
	in select type namespace if the selector has inferred type.
	* primary.cc (gfc_match_varspec): If a select type temporary
	is apparently scalar and a left parenthesis has been detected,
	check the current namespace has 'assoc_name_inferred' set. If
	so, set inferred_type.
	* resolve.cc (resolve_variable): If the namespace of a select
	type temporary is marked with 'assoc_name_inferred' call
	gfc_fixup_inferred_type_refs to ensure references are OK.
	(gfc_fixup_inferred_type_refs): Catch invalid array refs..

gcc/testsuite/
	PR fortran/114874
	* gfortran.dg/pr114874_1.f90: New test for valid code.
	* gfortran.dg/pr114874_2.f90: New test for invalid code.

6 files changed, 128 insertions, 9 deletions

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a7a0fdb..de1a7cd 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2242,6 +2242,10 @@ typedef struct gfc_namespace
   /* Set when resolve_types has been called for this namespace.  */
   unsigned types_resolved:1;
 
+  /* Set if the associate_name in a select type statement is an
+     inferred type.  */
+  unsigned assoc_name_inferred:1;
+
   /* Set to 1 if code has been generated for this namespace.  */
   unsigned translated:1;
 
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4539c9b..1851a8f 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6721,6 +6721,27 @@ gfc_match_select_type (void)
       goto cleanup;
     }
 
+  /* Select type namespaces are not filled until resolution. Therefore, the
+     namespace must be marked as having an inferred type associate name if
+     either expr1 is an inferred type variable or expr2 is. In the latter
+     case, as well as the symbol being marked as inferred type, it might be
+     that it has not been detected to be so. In this case the target has
+     unknown type. Once the namespace is marked, the fixups in resolution can
+     be triggered.  */
+  if (!expr2
+      && expr1->symtree->n.sym->assoc
+      && expr1->symtree->n.sym->assoc->inferred_type)
+    gfc_current_ns->assoc_name_inferred = 1;
+  else if (expr2 && expr2->expr_type == EXPR_VARIABLE
+	   && expr2->symtree->n.sym->assoc)
+    {
+      if (expr2->symtree->n.sym->assoc->inferred_type)
+	gfc_current_ns->assoc_name_inferred = 1;
+      else if (expr2->symtree->n.sym->assoc->target
+	       && expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
+	gfc_current_ns->assoc_name_inferred = 1;
+    }
+
   new_st.op = EXEC_SELECT_TYPE;
   new_st.expr1 = expr1;
   new_st.expr2 = expr2;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8e78337..76f6bcb 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2113,13 +2113,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 
   inferred_type = IS_INFERRED_TYPE (primary);
 
-  /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
-     selector has not been parsed, can generate errors with array and component
-     refs.. Use 'inferred_type' as a flag to suppress these errors.  */
+  /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
+     been parsed, can generate errors with array refs.. The SELECT TYPE
+     namespace is marked with 'assoc_name_inferred'. During resolution, this is
+     detected and gfc_fixup_inferred_type_refs is called.  */
   if (!inferred_type
-      && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
-      && !sym->attr.codimension
       && sym->attr.select_type_temporary
+      && sym->ns->assoc_name_inferred
       && !sym->attr.select_rank_temporary)
     inferred_type = true;
 
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4368627..d7a0856 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5888,6 +5888,9 @@ resolve_variable (gfc_expr *e)
       if (e->expr_type == EXPR_CONSTANT)
 	return true;
     }
+  else if (sym->attr.select_type_temporary
+	   && sym->ns->assoc_name_inferred)
+    gfc_fixup_inferred_type_refs (e);
 
   /* For variables that are used in an associate (target => object) where
      the object's basetype is array valued while the target is scalar,
@@ -6231,10 +6234,12 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
 	      free (new_ref);
 	    }
 	  else
-	  {
-	    e->ref = ref->next;
-	    free (ref);
-	  }
+	    {
+	      if (e->ref->u.ar.type == AR_UNKNOWN)
+		gfc_error ("Invalid array reference at %L", &e->where);
+	      e->ref = ref->next;
+	      free (ref);
+	    }
 	}
 
       /* It is possible for an inquiry reference to be mistaken for a
@@ -6315,6 +6320,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
 	  && e->ref->u.ar.type != AR_ELEMENT)
 	{
 	  ref = e->ref;
+	  if (ref->u.ar.type == AR_UNKNOWN)
+	    gfc_error ("Invalid array reference at %L", &e->where);
 	  e->ref = ref->next;
 	  free (ref);
 
@@ -6337,6 +6344,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
 	       && e->ref->next->u.ar.type != AR_ELEMENT)
 	{
 	  ref = e->ref->next;
+	  if (ref->u.ar.type == AR_UNKNOWN)
+	    gfc_error ("Invalid array reference at %L", &e->where);
 	  e->ref->next = e->ref->next->next;
 	  free (ref);
 	}
diff --git a/gcc/testsuite/gfortran.dg/pr114874_1.f90 b/gcc/testsuite/gfortran.dg/pr114874_1.f90
new file mode 100644
index 0000000..e385bb1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114874_1.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - valid code only.
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+module p
+  implicit none
+contains
+  subroutine foo
+    class(*), allocatable :: c
+    c = 'abc'
+    select type (c)
+    type is (character(*))
+      if (c .ne. 'abc') stop 1
+! Regression caused ICE here - valid substring reference
+      if (c(2:2) .ne. 'b') stop 2
+    end select
+  end
+  subroutine bar  ! This worked correctly
+    class(*), allocatable :: c(:)
+    c = ['abc','def']
+    select type (c)
+    type is (character(*))
+      if (any (c .ne. ['abc','def'])) stop 3
+      if (any (c(:)(2:2) .ne. ['b','e'])) stop 4
+    end select
+  end
+end module p
+
+  use p
+  call foo
+  call bar
+end
diff --git a/gcc/testsuite/gfortran.dg/pr114874_2.f90 b/gcc/testsuite/gfortran.dg/pr114874_2.f90
new file mode 100644
index 0000000..5028830
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114874_2.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - invalid code.
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+
+module q
+  type :: s
+    integer :: j
+  end type
+  type :: t
+    integer :: i
+    class(s), allocatable :: ca
+  end type
+contains
+  subroutine foobar
+    class(*), allocatable :: c
+    c = t (1)
+    select type (c)
+      type is (t)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+        if (c(1)%i .ne. 1) stop 5         ! { dg-error "Syntax error in IF-expression" }
+        if (allocated (c%ca)) then
+! Make sure that response is correct if problem is "nested".
+           select type (ca => c%ca)
+             type is (s)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+               if (ca(1)%j .ne. 1) stop 6 ! { dg-error "Syntax error in IF-expression" }
+           end select
+           select type (ca(1) => c%ca)    ! { dg-error "parse error in SELECT TYPE" }
+             type is (s)                  ! { dg-error "Unexpected TYPE IS statement" }
+               if (ca(1)%j .ne. 1) stop 6 ! { dg-error "nonderived-type variable" }
+           end select                     ! { dg-error " Expecting END IF statement" }
+        endif
+    end select
+
+! This problem was found in the course of the fix: Chunk taken from associate_64.f90,
+! the derived type and component names adapted and the invalid array reference added.
+    associate (var4 => bar4())
+      if (var4%i .ne. 84) stop 33
+      if (var4%ca%j .ne. 168) stop 34
+      select type (x => var4)
+        type is (t)
+          if (x(1)%i .ne. var4%i) stop 35 ! { dg-error "Invalid array reference" }
+          if (x%ca%j .ne. var4%ca%j) stop 36
+        class default
+          stop 37
+      end select
+    end associate
+  end
+  function bar4() result(res)
+    class(t), allocatable :: res
+    res = t(84, s(168))
+  end
+end module q