re PR fortran/88247 (ICE in get_array_ctor_var_strlen, at fortran/trans-array.c:2068)

2019-03-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/88247
	* expr.c (is_subref_array): Permit substrings to be detected
	as subref arrays.
	* trans-array.c (get_array_ctor_var_strlen): Obtain the length
	of deferred length strings. Handle substrings with a NULL end
	expression.
	(trans_array_constructor): Remove an unnecessary blank line.
	(gfc_conv_scalarized_array_ref): Skip to label 'done' if 'decl'
	is a pointer array.
	(get_array_charlen): If the expression is an array, convert the
	first element of the constructor and use its string length. Get
	a new charlen if necessary.
	(gfc_conv_expr_descriptor): Call 'get_array_charlen' for array
	constructor expressions. If the ss_info string length is
	available, use that to set the span of character arrays.
	* trans-expr.c (gfc_get_expr_charlen): Handle substrings
	* trans-stmt.c (trans_associate_var): Set the pointer array
	flag for variable targets and constant array constructors. Take
	care not to reset the string length or the span in the case of
	expressions that are not converted as direct by reference.

2019-03-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/88247
	* gfortran.dg/associate_47.f90: New test.

From-SVN: r269962

1 files changed, 55 insertions, 6 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1379426..2bc24d9 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2099,6 +2099,8 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
 	{
 	case REF_ARRAY:
 	  /* Array references don't change the string length.  */
+	  if (ts->deferred)
+	    get_array_ctor_all_strlen (block, expr, len);
 	  break;
 
 	case REF_COMPONENT:
@@ -2107,7 +2109,8 @@ get_array_ctor_var_strlen (stmtblock_t *block, gfc_expr * expr, tree * len)
 	  break;
 
 	case REF_SUBSTRING:
-	  if (ref->u.ss.start->expr_type != EXPR_CONSTANT
+	  if (ref->u.ss.end == NULL
+	      || ref->u.ss.start->expr_type != EXPR_CONSTANT
 	      || ref->u.ss.end->expr_type != EXPR_CONSTANT)
 	    {
 	      /* Note that this might evaluate expr.  */
@@ -2507,7 +2510,6 @@ trans_array_constructor (gfc_ss * ss, locus * where)
 			       ss_info->string_length);
 	  ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
 						     &length_se.pre);
-
 	  gfc_add_block_to_block (&outer_loop->pre, &length_se.pre);
 	  gfc_add_block_to_block (&outer_loop->post, &length_se.post);
 	}
@@ -3470,6 +3472,9 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
 					 || expr->expr_type == EXPR_FUNCTION))))
     decl = expr->symtree->n.sym->backend_decl;
 
+  if (decl && GFC_DECL_PTR_ARRAY_P (decl))
+    goto done;
+
   /* A pointer array component can be detected from its field decl. Fix
      the descriptor, mark the resulting variable decl and pass it to
      gfc_build_array_ref.  */
@@ -3486,6 +3491,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
 	decl = info->descriptor;
     }
 
+done:
   se->expr = gfc_build_array_ref (base, index, decl);
 }
 
@@ -6929,6 +6935,7 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
   gfc_formal_arglist *formal;
   gfc_actual_arglist *arg;
   gfc_se tse;
+  gfc_expr *e;
 
   if (expr->ts.u.cl->length
 	&& gfc_is_constant_expr (expr->ts.u.cl->length))
@@ -6940,6 +6947,34 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
 
   switch (expr->expr_type)
     {
+    case EXPR_ARRAY:
+
+      /* This is somewhat brutal. The expression for the first
+	 element of the array is evaluated and assigned to a
+	 new string length for the original expression.  */
+      e = gfc_constructor_first (expr->value.constructor)->expr;
+
+      gfc_init_se (&tse, NULL);
+      if (e->rank)
+	gfc_conv_expr_descriptor (&tse, e);
+      else
+	gfc_conv_expr (&tse, e);
+
+      gfc_add_block_to_block (&se->pre, &tse.pre);
+      gfc_add_block_to_block (&se->post, &tse.post);
+
+      if (!expr->ts.u.cl->backend_decl || !VAR_P (expr->ts.u.cl->backend_decl))
+	{
+	  expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+	  expr->ts.u.cl->backend_decl =
+			gfc_create_var (gfc_charlen_type_node, "sln");
+	}
+
+      gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+		      tse.string_length);
+
+      return;
+
     case EXPR_OP:
       get_array_charlen (expr->value.op.op1, se);
 
@@ -6947,7 +6982,7 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
       if (expr->value.op.op == INTRINSIC_PARENTHESES)
 	return;
 
-     expr->ts.u.cl->backend_decl =
+      expr->ts.u.cl->backend_decl =
 		gfc_create_var (gfc_charlen_type_node, "sln");
 
       if (expr->value.op.op2)
@@ -7325,7 +7360,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
   if (need_tmp)
     {
-      if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
+      if (expr->ts.type == BT_CHARACTER
+	  && (!expr->ts.u.cl->backend_decl || expr->expr_type == EXPR_ARRAY))
 	get_array_charlen (expr, se);
 
       /* Tell the scalarizer to make a temporary.  */
@@ -7447,7 +7483,17 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
       /* Set the string_length for a character array.  */
       if (expr->ts.type == BT_CHARACTER)
-	se->string_length =  gfc_get_expr_charlen (expr);
+	{
+	  se->string_length =  gfc_get_expr_charlen (expr);
+	  if (VAR_P (se->string_length)
+	      && expr->ts.u.cl->backend_decl == se->string_length)
+	    tmp = ss_info->string_length;
+	  else
+	    tmp = se->string_length;
+
+	  if (expr->ts.deferred)
+	    gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
+	}
 
       /* If we have an array section or are assigning make sure that
 	 the lower bound is 1.  References to the full
@@ -7509,7 +7555,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	}
 
       /* Set the span field.  */
-      tmp = gfc_get_array_span (desc, expr);
+      if (expr->ts.type == BT_CHARACTER && ss_info->string_length)
+	tmp = ss_info->string_length;
+      else
+	tmp = gfc_get_array_span (desc, expr);
       if (tmp != NULL_TREE)
 	gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);