re PR fortran/87151 (allocating array of character)

2018-10-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/87151
	* trans-array.c (gfc_get_array_span): Deal with deferred char
	array components having a TYPE_MAX_VALUE of zero.
	(gfc_array_init_size): Use the hidden string length component
	to build the descriptor dtype.
	(gfc_array_allocate): Remove the erroneous replacement of the
	charlen backend decl with a temporary.
	(gfc_conv_expr_descriptor): Use the ss_info string length in
	the case of deferred character components.
	(gfc_alloc_allocatable_for_assignment): Actually compare the
	string lengths for deferred characters. Make sure that kind > 1
	is handled correctly. Set the span field of the descriptor.
	* trans-intrinsic.c (gfc_conv_intrinsic_len): Remove the stupid
	comment.

	PR fortran/80931
	* trans-array.c (gfc_array_allocate): Set the span field for
	variable length character arrays.


2018-10-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/87151
	* gfortran.dg/deferred_type_component_3.f90: New test.

	PR fortran/80931
	* gfortran.dg/deferred_character_28.f90: New test.
	* gfortran.dg/deferred_character_29.f90: New test (note that
	this test appears in PR83196 comment #4 by mistake).

From-SVN: r264949

1 files changed, 70 insertions, 20 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1e8f777..c4df4eb 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -853,7 +853,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
 	 types if possible. Otherwise, return NULL_TREE.  */
       tmp = gfc_get_element_type (TREE_TYPE (desc));
       if (tmp && TREE_CODE (tmp) == ARRAY_TYPE
-	  && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE)
+	  && (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) == NULL_TREE
+	      || integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)))))
 	{
 	  if (expr->expr_type == EXPR_VARIABLE
 	      && expr->ts.type == BT_CHARACTER)
@@ -5366,6 +5367,28 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
       tmp = gfc_conv_descriptor_dtype (descriptor);
       gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
     }
+  else if (expr->ts.type == BT_CHARACTER
+	   && expr->ts.deferred
+	   && TREE_CODE (descriptor) == COMPONENT_REF)
+    {
+      /* Deferred character components have their string length tucked away
+	 in a hidden field of the derived type. Obtain that and use it to
+	 set the dtype. The charlen backend decl is zero because the field
+	 type is zero length.  */
+      gfc_ref *ref;
+      tmp = NULL_TREE;
+      for (ref = expr->ref; ref; ref = ref->next)
+	if (ref->type == REF_COMPONENT
+	    && gfc_deferred_strlen (ref->u.c.component, &tmp))
+	  break;
+      gcc_assert (tmp != NULL_TREE);
+      tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			     TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
+      tmp = fold_convert (gfc_charlen_type_node, tmp);
+      type = gfc_get_character_type_len (expr->ts.kind, tmp);
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (pblock, tmp, gfc_get_dtype_rank_type (rank, type));
+    }
   else
     {
       tmp = gfc_conv_descriptor_dtype (descriptor);
@@ -5774,16 +5797,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 
   if (expr->ts.type == BT_CHARACTER
       && TREE_CODE (se->string_length) == COMPONENT_REF
-      && expr->ts.u.cl->backend_decl != se->string_length)
-    {
-      if (VAR_P (expr->ts.u.cl->backend_decl))
-	gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
-			fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
-				      se->string_length));
-      else
-	expr->ts.u.cl->backend_decl = gfc_evaluate_now (se->string_length,
-							&se->pre);
-    }
+      && expr->ts.u.cl->backend_decl != se->string_length
+      && VAR_P (expr->ts.u.cl->backend_decl))
+    gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
+		    fold_convert (TREE_TYPE (expr->ts.u.cl->backend_decl),
+				  se->string_length));
 
   gfc_init_block (&set_descriptor_block);
   /* Take the corank only from the actual ref and not from the coref.  The
@@ -5871,17 +5889,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   if (dimension)
     gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
 
-  /* Pointer arrays need the span field to be set.  */
-  if (is_pointer_array (se->expr)
-      || (expr->ts.type == BT_CLASS
-	  && CLASS_DATA (expr)->attr.class_pointer)
+  /* Set the span field for pointer and deferred length character arrays.  */
+  if ((is_pointer_array (se->expr)
+       || (expr->ts.type == BT_CLASS && CLASS_DATA (expr)->attr.class_pointer)
+       || (expr->ts.type == BT_CHARACTER && TREE_CODE (se->string_length)
+							== COMPONENT_REF))
       || (expr->ts.type == BT_CHARACTER
-	  && TREE_CODE (se->string_length) == COMPONENT_REF))
+	  && (expr->ts.deferred || VAR_P (expr->ts.u.cl->backend_decl))))
     {
       if (expr3 && expr3_elem_size != NULL_TREE)
 	tmp = expr3_elem_size;
       else if (se->string_length
-	       && TREE_CODE (se->string_length) == COMPONENT_REF)
+	       && (TREE_CODE (se->string_length) == COMPONENT_REF
+		   || (expr->ts.type == BT_CHARACTER && expr->ts.deferred)))
 	{
 	  if (expr->ts.kind != 1)
 	    {
@@ -7053,6 +7073,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   tree offset;
   int full;
   bool subref_array_target = false;
+  bool deferred_array_component = false;
   gfc_expr *arg, *ss_expr;
 
   if (se->want_coarray)
@@ -7092,6 +7113,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       gfc_conv_ss_descriptor (&se->pre, ss, 0);
       desc = info->descriptor;
 
+      /* The charlen backend decl for deferred character components cannot
+	 be used because it is fixed at zero.  Instead, the hidden string
+	 length component is used.  */
+      if (expr->ts.type == BT_CHARACTER
+	  && expr->ts.deferred
+	  && TREE_CODE (desc) == COMPONENT_REF)
+	deferred_array_component = true;
+
       subref_array_target = se->direct_byref && is_subref_array (expr);
       need_tmp = gfc_ref_needs_temporary_p (expr->ref)
 			&& !subref_array_target;
@@ -7140,8 +7169,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	      se->expr = desc;
 	    }
 
-	  if (expr->ts.type == BT_CHARACTER)
+	  if (expr->ts.type == BT_CHARACTER && !deferred_array_component)
 	    se->string_length = gfc_get_expr_charlen (expr);
+	  /* The ss_info string length is returned set to the value of the
+	     hidden string length component.  */
+	  else if (deferred_array_component)
+	    se->string_length = ss_info->string_length;
 
 	  gfc_free_ss_chain (ss);
 	  return;
@@ -9797,8 +9830,15 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
 			 array1, build_int_cst (TREE_TYPE (array1), 0));
 
-  if (expr1->ts.deferred)
-    cond_null = gfc_evaluate_now (logical_true_node, &fblock);
+  if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      tmp = fold_build2_loc (input_location, NE_EXPR,
+			     logical_type_node,
+			     lss->info->string_length,
+			     rss->info->string_length);
+      cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				   logical_type_node, tmp, cond_null);
+    }
   else
     cond_null= gfc_evaluate_now (cond_null, &fblock);
 
@@ -10024,6 +10064,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
       else
 	gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+      if (expr1->ts.kind > 1)
+	tmp = fold_build2_loc (input_location, MULT_EXPR,
+			       TREE_TYPE (tmp),
+			       tmp, build_int_cst (TREE_TYPE (tmp),
+						   expr1->ts.kind));
     }
   else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
     {
@@ -10037,6 +10083,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   else
     tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
   tmp = fold_convert (gfc_array_index_type, tmp);
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+
   size2 = fold_build2_loc (input_location, MULT_EXPR,
 			   gfc_array_index_type,
 			   tmp, size2);