Fortran: Fix for regression in ASSOCIATE [PR112316]

2023-11-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/112316
	* parse.cc (parse_associate): Remove condition that caused this
	regression.

gcc/testsuite/
	PR fortran/112316
	* gfortran.dg/pr112316.f90: New test.

2 files changed, 125 insertions, 50 deletions

diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index e103ebe..abd3a42 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -5133,6 +5133,7 @@ parse_associate (void)
     {
       gfc_symbol* sym;
       gfc_expr *target;
+      int rank;
 
       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
 	gcc_unreachable ();
@@ -5196,62 +5197,57 @@ parse_associate (void)
 	    }
 	}
 
-      if (target->rank)
+      rank = target->rank;
+      /* Fixup cases where the ranks are mismatched.  */
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
 	{
-	  int rank = 0;
-	  rank = target->rank;
-	  /* When the rank is greater than zero then sym will be an array.  */
-	  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	  if ((!CLASS_DATA (sym)->as && rank != 0)
+	       || (CLASS_DATA (sym)->as
+		   && CLASS_DATA (sym)->as->rank != rank))
 	    {
-	      if ((!CLASS_DATA (sym)->as && rank != 0)
-		  || (CLASS_DATA (sym)->as
-		      && CLASS_DATA (sym)->as->rank != rank))
+	      /* Don't just (re-)set the attr and as in the sym.ts,
+	      because this modifies the target's attr and as.  Copy the
+	      data and do a build_class_symbol.  */
+	      symbol_attribute attr = CLASS_DATA (target)->attr;
+	      int corank = gfc_get_corank (target);
+	      gfc_typespec type;
+
+	      if (rank || corank)
 		{
-		  /* Don't just (re-)set the attr and as in the sym.ts,
-		     because this modifies the target's attr and as.  Copy the
-		     data and do a build_class_symbol.  */
-		  symbol_attribute attr = CLASS_DATA (target)->attr;
-		  int corank = gfc_get_corank (target);
-		  gfc_typespec type;
-
-		  if (rank || corank)
-		    {
-		      as = gfc_get_array_spec ();
-		      as->type = AS_DEFERRED;
-		      as->rank = rank;
-		      as->corank = corank;
-		      attr.dimension = rank ? 1 : 0;
-		      attr.codimension = corank ? 1 : 0;
-		    }
-		  else
-		    {
-		      as = NULL;
-		      attr.dimension = attr.codimension = 0;
-		    }
-		  attr.class_ok = 0;
-		  type = CLASS_DATA (sym)->ts;
-		  if (!gfc_build_class_symbol (&type,
-					       &attr, &as))
-		    gcc_unreachable ();
-		  sym->ts = type;
-		  sym->ts.type = BT_CLASS;
-		  sym->attr.class_ok = 1;
+		  as = gfc_get_array_spec ();
+		  as->type = AS_DEFERRED;
+		  as->rank = rank;
+		  as->corank = corank;
+		  attr.dimension = rank ? 1 : 0;
+		  attr.codimension = corank ? 1 : 0;
 		}
 	      else
-		sym->attr.class_ok = 1;
-	    }
-	  else if ((!sym->as && rank != 0)
-		   || (sym->as && sym->as->rank != rank))
-	    {
-	      as = gfc_get_array_spec ();
-	      as->type = AS_DEFERRED;
-	      as->rank = rank;
-	      as->corank = gfc_get_corank (target);
-	      sym->as = as;
-	      sym->attr.dimension = 1;
-	      if (as->corank)
-		sym->attr.codimension = 1;
+		{
+		  as = NULL;
+		  attr.dimension = attr.codimension = 0;
+		}
+	      attr.class_ok = 0;
+	      type = CLASS_DATA (sym)->ts;
+	      if (!gfc_build_class_symbol (&type, &attr, &as))
+		gcc_unreachable ();
+	      sym->ts = type;
+	      sym->ts.type = BT_CLASS;
+	      sym->attr.class_ok = 1;
 	    }
+	  else
+	    sym->attr.class_ok = 1;
+	}
+      else if ((!sym->as && rank != 0)
+	       || (sym->as && sym->as->rank != rank))
+	{
+	  as = gfc_get_array_spec ();
+	  as->type = AS_DEFERRED;
+	  as->rank = rank;
+	  as->corank = gfc_get_corank (target);
+	  sym->as = as;
+	  sym->attr.dimension = 1;
+	  if (as->corank)
+	    sym->attr.codimension = 1;
 	}
     }
 
diff --git a/gcc/testsuite/gfortran.dg/pr112316.f90 b/gcc/testsuite/gfortran.dg/pr112316.f90
new file mode 100644
index 0000000..df4dad7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112316.f90
@@ -0,0 +1,79 @@
+! { dg-do compile }
+!
+! This contains both testcases in the PR
+!
+! Contributed by Tomas Trnka  <trnka@scm.com>
+!
+! First testcase
+module BogusPointerArgError
+   implicit none
+
+   type :: AType
+   end type
+
+contains
+
+   subroutine A ()
+
+      class(AType), allocatable :: x
+
+      allocate(x)
+      call B (x)                       ! Was an error here
+   end subroutine
+
+   subroutine B (y)
+      class(AType), intent(in)    :: y
+   end subroutine
+
+   subroutine C (z)
+      class(AType), intent(in) :: z(:)
+
+      associate (xxx => z(1))
+      end associate
+
+   end subroutine
+
+end module
+
+! Second testcase
+module AModule
+   implicit none
+   private
+
+   public AType
+
+   type, abstract :: AType
+   contains
+      generic, public :: assignment(=) => Assign
+
+      procedure, private :: Assign
+   end type AType
+
+contains
+
+   subroutine Assign(lhs, rhs)
+      class(AType), intent(inout) :: lhs
+      class(AType), intent(in)    :: rhs
+   end subroutine
+
+end module AModule
+
+
+
+module ICEGetDescriptorField
+   use AModule
+   implicit none
+
+contains
+
+   subroutine Foo (x)
+      class(AType), intent(in)    :: x(:)
+
+      class(AType), allocatable :: y
+
+      associate (xxx => x(1))
+         y = xxx                       ! Was an ICE here
+      end associate
+   end subroutine
+
+end module ICEGetDescriptorField