2016-01-10 Paul Thomas <pault@gcc.gnu.org>

	Backport from mainline.
	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.

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

	Backport from mainline.
	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): Fix 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.

	Backport from mainline.
	PR fortran/67779
	* trans_array.c (gfc_conv_scalarized_array_ref): Add missing
	se->use_offset from condition for calculation of 'base'.

2015-01-10  Paul Thomas  <pault@gcc.gnu.org>

	Backport from mainline.
	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.

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

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

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

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

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

	Backport from mainline.
	PR fortran/67779
	* gfortran.dg/actual_array_offset_1: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-5-branch@232203 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/resolve.c

@@ -1,5 +1,5 @@
 /* Perform type resolution on the various structures.
-   Copyright (C) 2001-2015 Free Software Foundation, Inc.
+   Copyright (C) 2001-2016 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -8494,7 +8494,7 @@ resolve_transfer (gfc_code *code)
 	  return;
 	}
     }
-   
+
   if (exp->expr_type == EXPR_STRUCTURE)
     return;
 
@@ -9993,6 +9993,50 @@ generate_component_assignments (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.  */
 
@@ -10190,6 +10234,11 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 		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->attr.defined_assign_comp)
@@ -10562,7 +10611,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))
     {

gcc/fortran/trans-array.c

@@ -1,5 +1,5 @@
 /* Array translation routines
-   Copyright (C) 2002-2015 Free Software Foundation, Inc.
+   Copyright (C) 2002-2016 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -3112,7 +3112,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
     index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
 			     index, info->offset);
 
-  if (expr && is_subref_array (expr))
+  if (expr && (is_subref_array (expr)
+	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
     decl = expr->symtree->n.sym->backend_decl;
 
   tmp = build_fold_indirect_ref_loc (input_location, info->data);
@@ -4409,7 +4410,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
 	  if (!nDepend && dest_expr->rank > 0
 	      && dest_expr->ts.type == BT_CHARACTER
 	      && ss_expr->expr_type == EXPR_VARIABLE)
-	    
+
 	    nDepend = gfc_check_dependency (dest_expr, ss_expr, false);
 
 	  continue;
@@ -6945,7 +6946,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 				    gfc_array_index_type,
 				    stride, info->stride[n]);
 
-	  if (se->direct_byref
+	  if ((se->direct_byref || se->use_offset)
 	      && ((info->ref && info->ref->u.ar.type != AR_FULL)
 		  || (expr->expr_type == EXPR_ARRAY && se->use_offset)))
 	    {
@@ -8269,6 +8270,75 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
 }
 
 
+static tree
+concat_str_length (gfc_expr* expr)
+{
+  tree type;
+  tree len1;
+  tree len2;
+  gfc_se se;
+
+  type = gfc_typenode_for_spec (&expr->value.op.op1->ts);
+  len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  if (len1 == NULL_TREE)
+    {
+      if (expr->value.op.op1->expr_type == EXPR_OP)
+	len1 = concat_str_length (expr->value.op.op1);
+      else if (expr->value.op.op1->expr_type == EXPR_CONSTANT)
+	len1 = build_int_cst (gfc_charlen_type_node,
+			expr->value.op.op1->value.character.length);
+      else if (expr->value.op.op1->ts.u.cl->length)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr->value.op.op1->ts.u.cl->length);
+	  len1 = se.expr;
+	}
+      else
+	{
+	  /* Last resort!  */
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  se.descriptor_only = 1;
+	  gfc_conv_expr (&se, expr->value.op.op1);
+	  len1 = se.string_length;
+	}
+    }
+
+  type = gfc_typenode_for_spec (&expr->value.op.op2->ts);
+  len2 = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+  if (len2 == NULL_TREE)
+    {
+      if (expr->value.op.op2->expr_type == EXPR_OP)
+	len2 = concat_str_length (expr->value.op.op2);
+      else if (expr->value.op.op2->expr_type == EXPR_CONSTANT)
+	len2 = build_int_cst (gfc_charlen_type_node,
+			expr->value.op.op2->value.character.length);
+      else if (expr->value.op.op2->ts.u.cl->length)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr (&se, expr->value.op.op2->ts.u.cl->length);
+	  len2 = se.expr;
+	}
+      else
+	{
+	  /* Last resort!  */
+	  gfc_init_se (&se, NULL);
+	  se.want_pointer = 1;
+	  se.descriptor_only = 1;
+	  gfc_conv_expr (&se, expr->value.op.op2);
+	  len2 = se.string_length;
+	}
+    }
+
+  gcc_assert(len1 && len2);
+  len1 = fold_convert (gfc_charlen_type_node, len1);
+  len2 = fold_convert (gfc_charlen_type_node, len2);
+
+  return fold_build2_loc (input_location, PLUS_EXPR,
+			  gfc_charlen_type_node, len1, len2);
+}
+
+
 /* Allocate the lhs of an assignment to an allocatable array, otherwise
    reallocate it.  */
 
@@ -8366,6 +8436,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   /* Allocate if data is NULL.  */
   cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 			 array1, build_int_cst (TREE_TYPE (array1), 0));
+
+  if (expr1->ts.deferred)
+    cond_null = gfc_evaluate_now (boolean_true_node, &fblock);
+  else
+    cond_null= gfc_evaluate_now (cond_null, &fblock);
+
   tmp = build3_v (COND_EXPR, cond_null,
 		  build1_v (GOTO_EXPR, jump_label1),
 		  build_empty_stmt (input_location));
@@ -8454,7 +8530,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 
   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 			  size1, size2);
-  neq_size = gfc_evaluate_now (cond, &fblock);
+
+  /* If the lhs is deferred length, assume that the element size
+     changes and force a reallocation.  */
+  if (expr1->ts.deferred)
+    neq_size = gfc_evaluate_now (boolean_true_node, &fblock);
+  else
+    neq_size = gfc_evaluate_now (cond, &fblock);
 
   /* Deallocation of allocatable components will have to occur on
      reallocation.  Fix the old descriptor now.  */
@@ -8559,6 +8641,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
       else
 	{
 	  tmp = expr2->ts.u.cl->backend_decl;
+	  if (!tmp && expr2->expr_type == EXPR_OP
+	      && expr2->value.op.op == INTRINSIC_CONCAT)
+	    {
+	      tmp = concat_str_length (expr2);
+	      expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+	    }
 	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
 	}
 
@@ -8586,6 +8674,22 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 			   size2, size_one_node);
   size2 = gfc_evaluate_now (size2, &fblock);
 
+  /* For deferred character length, the 'size' field of the dtype might
+     have changed so set the dtype.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+      && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+    {
+      tree type;
+      tmp = gfc_conv_descriptor_dtype (desc);
+      if (expr2->ts.u.cl->backend_decl)
+	type = gfc_typenode_for_spec (&expr2->ts);
+      else
+	type = gfc_typenode_for_spec (&expr1->ts);
+
+      gfc_add_modify (&fblock, tmp,
+		      gfc_get_dtype_rank_type (expr1->rank,type));
+    }
+
   /* Realloc expression.  Note that the scalarizer uses desc.data
      in the array reference - (*desc.data)[<element>].  */
   gfc_init_block (&realloc_block);
@@ -8628,8 +8732,16 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 			     1, size2);
   gfc_conv_descriptor_data_set (&alloc_block,
 				desc, tmp);
-  tmp = gfc_conv_descriptor_dtype (desc);
-  gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+
+  /* We already set the dtype in the case of deferred character
+     length arrays.  */
+  if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+        && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred))
+    {
+      tmp = gfc_conv_descriptor_dtype (desc);
+      gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+    }
+
   if ((expr1->ts.type == BT_DERIVED)
 	&& expr1->ts.u.derived->attr.alloc_comp)
     {

gcc/fortran/trans-expr.c

@@ -1,5 +1,5 @@
 /* Expression translation
-   Copyright (C) 2002-2015 Free Software Foundation, Inc.
+   Copyright (C) 2002-2016 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -5343,7 +5343,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  else
 	    {
 	      tmp = parmse.string_length;
-	      if (TREE_CODE (tmp) != VAR_DECL)
+	      if (TREE_CODE (tmp) != VAR_DECL
+		  && TREE_CODE (tmp) != COMPONENT_REF)
 		tmp = gfc_evaluate_now (parmse.string_length, &se->pre);
 	      parmse.string_length = gfc_build_addr_expr (NULL_TREE, tmp);
 	    }
@@ -8998,8 +8999,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
     }
 
   /* Stabilize a string length for temporaries.  */
-  if (expr2->ts.type == BT_CHARACTER)
+  if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
     string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+  else if (expr2->ts.type == BT_CHARACTER)
+    string_length = rse.string_length;
   else
     string_length = NULL_TREE;
 
@@ -9033,8 +9036,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      the function call must happen before the (re)allocation of the lhs -
      otherwise the character length of the result is not known.
      NOTE: This relies on having the exact dependence of the length type
-     parameter available to the caller; gfortran saves it in the .mod files.  */
-  if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred)
+     parameter available to the caller; gfortran saves it in the .mod files.
+     NOTE ALSO: The concatenation operation generates a temporary pointer,
+     whose allocation must go to the innermost loop.  */
+  if (flag_realloc_lhs
+      && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred
+      && !(lss != gfc_ss_terminator
+	   && expr2->expr_type == EXPR_OP
+	   && expr2->value.op.op == INTRINSIC_CONCAT))
     gfc_add_block_to_block (&block, &rse.pre);
 
   /* Nullify the allocatable components corresponding to those of the lhs

gcc/fortran/trans-stmt.c

@@ -1,5 +1,5 @@
 /* Statement translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002-2015 Free Software Foundation, Inc.
+   Copyright (C) 2002-2016 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -5119,6 +5119,7 @@ gfc_trans_allocate (gfc_code * code)
   tree label_finish;
   tree memsz;
   tree al_vptr, al_len;
+  tree def_str_len = NULL_TREE;
   /* If an expr3 is present, then store the tree for accessing its
      _vptr, and _len components in the variables, respectively.  The
      element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
@@ -5381,6 +5382,7 @@ gfc_trans_allocate (gfc_code * code)
 	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
 					 TREE_TYPE (se_sz.expr),
 					 tmp, se_sz.expr);
+	  def_str_len = gfc_evaluate_now (se_sz.expr, &block);
 	}
     }
 
@@ -5432,6 +5434,17 @@ gfc_trans_allocate (gfc_code * code)
 
       se.want_pointer = 1;
       se.descriptor_only = 1;
+
+      if (expr->ts.type == BT_CHARACTER
+	  && expr->ts.deferred
+	  && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
+	  && def_str_len != NULL_TREE)
+	{
+	  tmp = expr->ts.u.cl->backend_decl;
+	  gfc_add_modify (&block, tmp,
+			  fold_convert (TREE_TYPE (tmp), def_str_len));
+	}
+
       gfc_conv_expr (&se, expr);
       if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
 	/* se.string_length now stores the .string_length variable of expr

gcc/fortran/trans-types.c

@@ -1,5 +1,5 @@
 /* Backend support for Fortran 95 basic types and derived types.
-   Copyright (C) 2002-2015 Free Software Foundation, Inc.
+   Copyright (C) 2002-2016 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>