re PR fortran/50221 (Allocatable string length fails with array assignment)

2015-11-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/50221
	PR fortran/68216
	PR fortran/63932
	PR fortran/66408
	* trans_array.c (gfc_conv_scalarized_array_ref): Pass the
	symbol decl for deferred character length array references.
	* trans-stmt.c (gfc_trans_allocate): Keep the string lengths
	to update deferred length character string lengths.
	* trans-types.c (gfc_get_dtype_rank_type); Use the string
	length of deferred character types for the dtype size.
	* trans.c (gfc_build_array_ref): For references to deferred
	character arrays, use the domain max value, if it is a variable
	to set the 'span' and use pointer arithmetic for acces to the
	element.
	(trans_code): Set gfc_current_locus for diagnostic purposes.

	PR fortran/67674
	* trans-expr.c (gfc_conv_procedure_call): Do not fix deferred
	string lengths of components.

	PR fortran/49954
	* resolve.c (deferred_op_assign): New function.
	(gfc_resolve_code): Call it.
	* trans-array.c (concat_str_length): New function.
	(gfc_alloc_allocatable_for_assignment): Jump directly to alloc/
	realloc blocks for deferred character length arrays because the
	string length might change, even if the shape is the same. Call
	concat_str_length to obtain the string length for concatenation
	since it is needed to compute the lhs string length.
	Set the descriptor dtype appropriately for the new string
	length.
	* trans-expr.c (gfc_trans_assignment_1): Use the rse string
	length for all characters, other than deferred types. For
	concatenation operators, push the rse.pre block to the inner
	most loop so that the temporary pointer and the assignments
	are properly placed.

2015-11-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/50221
	* gfortran.dg/deferred_character_1.f90: New test.
	* gfortran.dg/deferred_character_4.f90: New test for comment
	#4 of the PR.

	PR fortran/68216
	* gfortran.dg/deferred_character_2.f90: New test.

	PR fortran/67674
	* gfortran.dg/deferred_character_3.f90: New test.

	PR fortran/63932
	* gfortran.dg/deferred_character_5.f90: New test.

	PR fortran/66408
	* gfortran.dg/deferred_character_6.f90: New test.

	PR fortran/49954
	* gfortran.dg/deferred_character_7.f90: New test.

From-SVN: r230396

1 files changed, 50 insertions, 1 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bf2837c..90bc6d4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10222,6 +10222,50 @@ resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns)
 }
 
 
+/* Deferred character length assignments from an operator expression
+   require a temporary because the character length of the lhs can
+   change in the course of the assignment.  */
+
+static bool
+deferred_op_assign (gfc_code **code, gfc_namespace *ns)
+{
+  gfc_expr *tmp_expr;
+  gfc_code *this_code;
+
+  if (!((*code)->expr1->ts.type == BT_CHARACTER
+	 && (*code)->expr1->ts.deferred && (*code)->expr1->rank
+	 && (*code)->expr2->expr_type == EXPR_OP))
+    return false;
+
+  if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1))
+    return false;
+
+  tmp_expr = get_temp_from_expr ((*code)->expr1, ns);
+  tmp_expr->where = (*code)->loc;
+
+  /* A new charlen is required to ensure that the variable string
+     length is different to that of the original lhs.  */
+  tmp_expr->ts.u.cl = gfc_get_charlen();
+  tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl;
+  tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next;
+  (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl;
+
+  tmp_expr->symtree->n.sym->ts.deferred = 1;
+
+  this_code = build_assignment (EXEC_ASSIGN,
+				(*code)->expr1,
+				gfc_copy_expr (tmp_expr),
+				NULL, NULL, (*code)->loc);
+
+  (*code)->expr1 = tmp_expr;
+
+  this_code->next = (*code)->next;
+  (*code)->next = this_code;
+
+  return true;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -10427,6 +10471,11 @@ start:
 		goto call;
 	    }
 
+	  /* Check for dependencies in deferred character length array
+	     assignments and generate a temporary, if necessary.  */
+	  if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns))
+	    break;
+
 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
 	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
 	      && code->expr1->ts.u.derived
@@ -10801,7 +10850,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
       sym->binding_label = NULL;
 
     }
-  else if (sym->attr.flavor == FL_VARIABLE && module 
+  else if (sym->attr.flavor == FL_VARIABLE && module
 	   && (strcmp (module, gsym->mod_name) != 0
 	       || strcmp (sym->name, gsym->sym_name) != 0))
     {