Fortran: Fix some problems with SELECT TYPE selectors [PR104625].

2023-10-27  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/104625
	* expr.cc (gfc_check_vardef_context): Check that the target
	does have a vector index before emitting the specific error.
	* match.cc (copy_ts_from_selector_to_associate): Ensure that
	class valued operator expressions set the selector rank and
	use the rank to provide the associate variable with an
	appropriate array spec.
	* resolve.cc (resolve_operator): Reduce stacked parentheses to
	a single pair.
	(fixup_array_ref): Extract selector symbol from parentheses.

gcc/testsuite/
	PR fortran/104625
	* gfortran.dg/pr104625.f90: New test.
	* gfortran.dg/associate_55.f90: Change error check.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 663fe63dea68f0152916cc9e555d0ecfb6b006bf..c668baeef8c33a3d7d421243abd872f12c0cbc86 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -6474,7 +6474,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
        {
          if (context)
            {
-             if (assoc->target->expr_type == EXPR_VARIABLE)
+             if (assoc->target->expr_type == EXPR_VARIABLE
+                 && gfc_has_vector_index (assoc->target))
                gfc_error ("%qs at %L associated to vector-indexed target"
                           " cannot be used in a variable definition"
                           " context (%s)",

diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 148a86bb436db6986c4f8375d27141b8e84d7dbc..f848e52be4c142d84559e27d1a2a7096b266a0ee 100644 (file)
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6348,12 +6348,13 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
   else if (selector->ts.type == BT_CLASS
           && CLASS_DATA (selector)
           && CLASS_DATA (selector)->as
-          && ref && ref->type == REF_ARRAY)
+          && ((ref && ref->type == REF_ARRAY)
+              || selector->expr_type == EXPR_OP))
     {
       /* Ensure that the array reference type is set.  We cannot use
         gfc_resolve_expr at this point, so the usable parts of
         resolve.cc(resolve_array_ref) are employed to do it.  */
-      if (ref->u.ar.type == AR_UNKNOWN)
+      if (ref && ref->u.ar.type == AR_UNKNOWN)
        {
          ref->u.ar.type = AR_ELEMENT;
          for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
@@ -6367,7 +6368,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
              }
        }
 
-      if (ref->u.ar.type == AR_FULL)
+      if (!ref || ref->u.ar.type == AR_FULL)
        selector->rank = CLASS_DATA (selector)->as->rank;
       else if (ref->u.ar.type == AR_SECTION)
        selector->rank = ref->u.ar.dimen;
@@ -6379,12 +6380,15 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
 
   if (rank)
     {
-      for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
-       if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
-           || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
-               && ref->u.ar.end[i] == NULL
-               && ref->u.ar.stride[i] == NULL))
-         rank--;
+      if (ref)
+       {
+         for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+           if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
+             || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
+                 && ref->u.ar.end[i] == NULL
+                 && ref->u.ar.stride[i] == NULL))
+             rank--;
+       }
 
       if (rank)
        {

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 861f69ac20fd79405283416dd6a09d5e1e9de191..9f4dc0726457e584a0590ecabf87e4de099b95c6 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -4138,6 +4138,16 @@ resolve_operator (gfc_expr *e)
   bool dual_locus_error;
   bool t = true;
 
+  /* Reduce stacked parentheses to single pair  */
+  while (e->expr_type == EXPR_OP
+        && e->value.op.op == INTRINSIC_PARENTHESES
+        && e->value.op.op1->expr_type == EXPR_OP
+        && e->value.op.op1->value.op.op == INTRINSIC_PARENTHESES)
+    {
+      gfc_expr *tmp = gfc_copy_expr (e->value.op.op1);
+      gfc_replace_expr (e, tmp);
+    }
+
   /* Resolve all subnodes-- give them types.  */
 
   switch (e->value.op.op)
@@ -9451,8 +9461,25 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
 {
   gfc_ref *nref = (*expr1)->ref;
   gfc_symbol *sym1 = (*expr1)->symtree->n.sym;
-  gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL;
+  gfc_symbol *sym2;
+  gfc_expr *selector = gfc_copy_expr (expr2);
+
   (*expr1)->rank = rank;
+  if (selector)
+    {
+      gfc_resolve_expr (selector);
+      if (selector->expr_type == EXPR_OP
+         && selector->value.op.op == INTRINSIC_PARENTHESES)
+       sym2 = selector->value.op.op1->symtree->n.sym;
+      else if (selector->expr_type == EXPR_VARIABLE
+              || selector->expr_type == EXPR_FUNCTION)
+       sym2 = selector->symtree->n.sym;
+      else
+       gcc_unreachable ();
+    }
+  else
+    sym2 = NULL;
+
   if (sym1->ts.type == BT_CLASS)
     {
       if ((*expr1)->ts.type != BT_CLASS)

diff --git a/gcc/testsuite/gfortran.dg/associate_55.f90 b/gcc/testsuite/gfortran.dg/associate_55.f90
index 2b9e8c727f901355ee66f35c4fbed2b49de5b148..245dbfc7218287ee6f36a5f6a4822e8662237e6a 100644 (file)
--- a/gcc/testsuite/gfortran.dg/associate_55.f90
+++ b/gcc/testsuite/gfortran.dg/associate_55.f90
@@ -26,7 +26,7 @@ contains
     class(test_t), intent(inout) :: obj
     integer, intent(in) :: a
     associate (state => obj%state(TEST_STATES)) ! { dg-error "no IMPLICIT type" }
-      state = a                                 ! { dg-error "vector-indexed target" }
+      state = a  ! { dg-error "cannot be used in a variable definition context" }
 !      state(TEST_STATE) = a
     end associate
   end subroutine test_alter_state2

diff --git a/gcc/testsuite/gfortran.dg/pr104625.f90 b/gcc/testsuite/gfortran.dg/pr104625.f90
new file mode 100644 (file)
index 0000000..84e7a9a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr104625.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! Check the fix for PR104625 in which the selectors in parentheses used
+! to cause ICEs. The "Unclassifiable statement" errors were uncovered once
+! the ICEs were fixed.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+  implicit none
+  type t
+     integer :: a
+  end type
+contains
+  subroutine s(x)
+!   class(t) :: x          ! Was OK
+    class(t) :: x(:)       ! Used to ICE in combination with below
+    class(t), allocatable :: r(:)
+
+    select type (y =>  x)  ! OK
+      type is (t)
+        y%a = 99
+    end select
+    select type (z => (x))  ! Used to ICE
+      type is (t)
+        r = z(1)            ! Used to give "Unclassifiable statement" error
+        z%a = 99            ! { dg-error "cannot be used in a variable definition" }
+    end select
+    select type (u => ((x))) ! Used to ICE
+      type is (t)
+        r = u(1)            ! Used to give "Unclassifiable statement" error
+        u%a = 99            ! { dg-error "cannot be used in a variable definition" }
+    end select
+  end
+end