Fortran: Fix some more blockers in associate meta-bug [PR87477]

2023-06-08  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	PR fortran/99350
	PR fortran/107821
	PR fortran/109451
	* decl.cc (char_len_param_value): Simplify a copy of the expr
	and replace the original if there is no error.
	* gfortran.h : Remove the redundant field 'rankguessed' from
	'gfc_association_list'.
	* resolve.cc (resolve_assoc_var): Remove refs to 'rankguessed'.
	(resolve_variable): Associate names with constant or structure
	constructor targets cannot have array refs.
	* trans-array.cc (gfc_conv_expr_descriptor): Guard expression
	character length backend decl before using it. Suppress the
	assignment if lhs equals rhs.
	* trans-io.cc (gfc_trans_transfer): Scalarize transfer of
	associate variables pointing to a variable. Add comment.
	* trans-stmt.cc (trans_associate_var): Remove requirement that
	the character length be deferred before assigning the value
	returned by gfc_conv_expr_descriptor. Also, guard the backend
	decl before testing with VAR_P.

gcc/testsuite/
	PR fortran/99350
	* gfortran.dg/pr99350.f90 : New test.

	PR fortran/107821
	* gfortran.dg/associate_5.f03 : Changed error message.
	* gfortran.dg/pr107821.f90 : New test.

	PR fortran/109451
	* gfortran.dg/associate_61.f90 : New test

10 files changed, 113 insertions, 17 deletions

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index f5d39e2..d09c8bc 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1056,6 +1056,7 @@ static match
 char_len_param_value (gfc_expr **expr, bool *deferred)
 {
   match m;
+  gfc_expr *p;
 
   *expr = NULL;
   *deferred = false;
@@ -1081,10 +1082,10 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
   if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
     return MATCH_ERROR;
 
-  /* If gfortran gets an EXPR_OP, try to simplify it.  This catches things
-     like CHARACTER(([1])).   */
-  if ((*expr)->expr_type == EXPR_OP)
-    gfc_simplify_expr (*expr, 1);
+  /* Try to simplify the expression to catch things like CHARACTER(([1])).   */
+  p = gfc_copy_expr (*expr);
+  if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
+    gfc_replace_expr (*expr, p);
 
   if ((*expr)->expr_type == EXPR_FUNCTION)
     {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 33ca498..a58c60e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2922,9 +2922,6 @@ typedef struct gfc_association_list
      for memory handling.  */
   unsigned dangling:1;
 
-  /* True when the rank of the target expression is guessed during parsing.  */
-  unsigned rankguessed:1;
-
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symtree *st; /* Symtree corresponding to name.  */
   locus where;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index fd059dd..50b49d0 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5872,7 +5872,15 @@ resolve_variable (gfc_expr *e)
       if (sym->ts.type == BT_CLASS)
 	gfc_fix_class_refs (e);
       if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
-	return false;
+	{
+	  /* Unambiguously scalar!  */
+	  if (sym->assoc->target
+	      && (sym->assoc->target->expr_type == EXPR_CONSTANT
+		  || sym->assoc->target->expr_type == EXPR_STRUCTURE))
+	    gfc_error ("Scalar variable %qs has an array reference at %L",
+		       sym->name, &e->where);
+	  return false;
+	}
       else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
 	{
 	  /* This can happen because the parser did not detect that the
@@ -9279,7 +9287,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       gfc_array_spec *as;
       /* The rank may be incorrectly guessed at parsing, therefore make sure
 	 it is corrected now.  */
-      if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed))
+      if (sym->ts.type != BT_CLASS && !sym->as)
 	{
 	  if (!sym->as)
 	    sym->as = gfc_get_array_spec ();
@@ -9292,8 +9300,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	    sym->attr.codimension = 1;
 	}
       else if (sym->ts.type == BT_CLASS
-	       && CLASS_DATA (sym)
-	       && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+	       && CLASS_DATA (sym) && !CLASS_DATA (sym)->as)
 	{
 	  if (!CLASS_DATA (sym)->as)
 	    CLASS_DATA (sym)->as = gfc_get_array_spec ();
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 1c7ea90..e1c75e9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7934,7 +7934,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  else
 	    tmp = se->string_length;
 
-	  if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl))
+	  if (expr->ts.deferred && expr->ts.u.cl->backend_decl
+	      && VAR_P (expr->ts.u.cl->backend_decl))
 	    gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
 	  else
 	    expr->ts.u.cl->backend_decl = tmp;
@@ -7999,6 +8000,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    }
 	}
 
+      if (expr->ts.type == BT_CHARACTER
+	  && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
+	{
+	  tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
+	  gfc_add_modify (&loop.pre, elem_len,
+			  fold_convert (TREE_TYPE (elem_len),
+			  gfc_get_array_span (desc, expr)));
+	}
+
       /* Set the span field.  */
       tmp = NULL_TREE;
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 0c0e333..e36ad0e 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2620,9 +2620,13 @@ gfc_trans_transfer (gfc_code * code)
 	  gcc_assert (ref && ref->type == REF_ARRAY);
 	}
 
+      /* These expressions don't always have the dtype element length set
+	 correctly, rendering them useless for array transfer.  */
       if (expr->ts.type != BT_CLASS
 	 && expr->expr_type == EXPR_VARIABLE
 	 && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
+	     || (expr->symtree->n.sym->assoc
+		 && expr->symtree->n.sym->assoc->variable)
 	     || gfc_expr_attr (expr).pointer))
 	goto scalarize;
 
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index b5b8294..dcabeca 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1930,15 +1930,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_conv_expr_descriptor (&se, e);
 
       if (sym->ts.type == BT_CHARACTER
-	  && sym->ts.deferred
 	  && !sym->attr.select_type_temporary
+	  && sym->ts.u.cl->backend_decl
 	  && VAR_P (sym->ts.u.cl->backend_decl)
 	  && se.string_length != sym->ts.u.cl->backend_decl)
-	{
-	  gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+	gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
 			  fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
 					se.string_length));
-	}
 
       /* If we didn't already do the pointer assignment, set associate-name
 	 descriptor to the one generated for the temporary.  */
diff --git a/gcc/testsuite/gfortran.dg/associate_5.f03 b/gcc/testsuite/gfortran.dg/associate_5.f03
index 64345d3..c91f88f 100644
--- a/gcc/testsuite/gfortran.dg/associate_5.f03
+++ b/gcc/testsuite/gfortran.dg/associate_5.f03
@@ -11,7 +11,7 @@ PROGRAM main
   INTEGER, POINTER :: ptr
 
   ASSOCIATE (a => 5) ! { dg-error "is used as array" }
-    PRINT *, a(3)
+    PRINT *, a(3) ! { dg-error "has an array reference" }
   END ASSOCIATE
 
   ASSOCIATE (a => nontarget)
diff --git a/gcc/testsuite/gfortran.dg/associate_61.f90 b/gcc/testsuite/gfortran.dg/associate_61.f90
new file mode 100644
index 0000000..da55288
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_61.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! Test fixes for PR109451
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+program p
+   implicit none
+   character(4) :: c(2) = ["abcd","efgh"]
+   call dcs3 (c)
+   call dcs0 (c)
+contains
+  subroutine dcs3 (a)
+    character(len=*), intent(in)  :: a(:)
+    character(:),     allocatable :: b(:)
+    b = a(:)
+    call test (b, a, 1)
+    associate (q => b(:))    ! no ICE but print repeated first element
+      call test (q, a, 2)
+      print *, q             ! Checked with dg-output
+      q = q(:)(2:3)
+    end associate
+    call test (b, ["bc  ","fg  "], 4)
+    b = a(:)
+    associate (q => b(:)(:)) ! ICE
+      call test (q, a, 3)
+      associate (r => q(:)(1:3))
+        call test (r, a(:)(1:3), 5)
+      end associate
+    end associate
+    associate (q => b(:)(2:3))
+      call test (q, a(:)(2:3), 6)
+    end associate
+  end subroutine dcs3
+
+! The associate vars in dsc0 had string length not set
+  subroutine dcs0 (a)
+    character(len=*), intent(in) :: a(:)
+    associate (q => a)
+      call test (q, a, 7)
+    end associate
+    associate (q => a(:))
+      call test (q, a, 8)
+    end associate
+    associate (q => a(:)(:))
+      call test (q, a, 9)
+    end associate
+  end subroutine dcs0
+
+  subroutine test (x, y, i)
+    character(len=*), intent(in) :: x(:), y(:)
+    integer, intent(in) :: i
+    if (any (x .ne. y)) stop i
+  end subroutine test
+end program p
+! { dg-output " abcdefgh" }
diff --git a/gcc/testsuite/gfortran.dg/pr107821.f90 b/gcc/testsuite/gfortran.dg/pr107821.f90
new file mode 100644
index 0000000..5d86997
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107821.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   associate (a => 1)
+      print *, [character((a(1))) :: '1'] ! { dg-error "has an array reference" }
+   end associate
+end
diff --git a/gcc/testsuite/gfortran.dg/pr99350.f90 b/gcc/testsuite/gfortran.dg/pr99350.f90
new file mode 100644
index 0000000..7f751b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99350.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+      character(:), pointer :: a
+   end type
+   type(t) :: z
+   character((0.)/0), target :: c = 'abc' ! { dg-error "Division by zero" }
+   z%a => c
+! The associate statement was not needed to trigger the ICE.
+   associate (y => z%a)
+      print *, y
+   end associate
+end