2014-03-06 Paul Thomas <pault@gcc.gnu.org>

	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/51976
	* gfortran.h (symbol_attribute): Add deferred_parameter attribute.
	* primary.c (build_actual_constructor): It is not an error if
	a missing component has the deferred_parameter attribute;
	equally, if one is given a value, it is an error.
	* resolve.c (resolve_fl_derived0): Remove error for deferred
	character length components.  Add the hidden string length
	field to the structure. Give it the deferred_parameter
	attribute.
	* trans-array.c (duplicate_allocatable): Add a strlen field
	which is used as the element size if it is non-null.
	(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Pass a
	NULL to the new argument in duplicate_allocatable.
	(structure_alloc_comps): Set the hidden string length as
	appropriate. Use it in calls to duplicate_allocatable.
	(gfc_alloc_allocatable_for_assignment): When a deferred length
	backend declaration is variable, use that; otherwise use the
	string length from the expression evaluation.
	* trans-expr.c (gfc_conv_component_ref): If this is a deferred
	character length component, the string length should have the
	value of the hidden string length field.
	(gfc_trans_subcomponent_assign): Set the hidden string length
	field for deferred character length components.  Allocate the
	necessary memory for the string.
	(alloc_scalar_allocatable_for_assignment): Same change as in
	gfc_alloc_allocatable_for_assignment above.
	* trans-stmt.c (gfc_trans_allocate): Likewise.
	* trans-intrinsic (size_of_string_in_bytes): Make non-static.
	* trans-types.c (gfc_get_derived_type): Set the tree type for
	a deferred character length component.
	* trans.c (gfc_deferred_strlen): New function.
	* trans.h (size_of_string_in_bytes,gfc_deferred_strlen): New prototypes.


2014-03-06  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/51976
	* gfortran.dg/deferred_type_component_1.f90 : New test.
	* gfortran.dg/deferred_type_component_2.f90 : New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@208386 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 61 insertions, 12 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 8e7b75ed601..153ef67e49e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7365,7 +7365,7 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
 
 static tree
 duplicate_allocatable (tree dest, tree src, tree type, int rank,
-		       bool no_malloc)
+		       bool no_malloc, tree str_sz)
 {
   tree tmp;
   tree size;
@@ -7386,7 +7386,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
       null_data = gfc_finish_block (&block);
 
       gfc_init_block (&block);
-      size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+      if (str_sz != NULL_TREE)
+	size = str_sz;
+      else
+	size = TYPE_SIZE_UNIT (TREE_TYPE (type));
+
       if (!no_malloc)
 	{
 	  tmp = gfc_call_malloc (&block, type, size);
@@ -7410,8 +7414,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
       else
 	nelems = gfc_index_one_node;
 
-      tmp = fold_convert (gfc_array_index_type,
-			  TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      if (str_sz != NULL_TREE)
+	tmp = fold_convert (gfc_array_index_type, str_sz);
+      else
+	tmp = fold_convert (gfc_array_index_type,
+			    TYPE_SIZE_UNIT (gfc_get_element_type (type)));
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      nelems, tmp);
       if (!no_malloc)
@@ -7452,7 +7459,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
 tree
 gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
 {
-  return duplicate_allocatable (dest, src, type, rank, false);
+  return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
 }
 
 
@@ -7461,7 +7468,7 @@ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
 tree
 gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
 {
-  return duplicate_allocatable (dest, src, type, rank, true);
+  return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
 }
 
 
@@ -7718,6 +7725,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 				     void_type_node, comp,
 				     build_int_cst (TREE_TYPE (comp), 0));
 	      gfc_add_expr_to_block (&fnblock, tmp);
+	      if (gfc_deferred_strlen (c, &comp))
+		{
+		  comp = fold_build3_loc (input_location, COMPONENT_REF,
+					  TREE_TYPE (comp),
+					  decl, comp, NULL_TREE);
+		  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+					 TREE_TYPE (comp), comp,
+					 build_int_cst (TREE_TYPE (comp), 0));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		}
 	    }
 	  else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
 	    {
@@ -7855,8 +7872,26 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      continue;
 	    }
 
-	  if (c->attr.allocatable && !c->attr.proc_pointer
-	      && !cmp_has_alloc_comps)
+	  if (gfc_deferred_strlen (c, &tmp))
+	    {
+	      tree len, size;
+	      len = tmp;
+	      tmp = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     decl, len, NULL_TREE);
+	      len = fold_build3_loc (input_location, COMPONENT_REF,
+				     TREE_TYPE (len),
+				     dest, len, NULL_TREE);
+	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+				     TREE_TYPE (len), len, tmp);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	      size = size_of_string_in_bytes (c->ts.kind, len);
+	      tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
+					   false, size);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if (c->attr.allocatable && !c->attr.proc_pointer
+		   && !cmp_has_alloc_comps)
 	    {
 	      rank = c->as ? c->as->rank : 0;
 	      if (c->attr.codimension)
@@ -8342,10 +8377,24 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   /* Get the new lhs size in bytes.  */
   if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
     {
-      tmp = expr2->ts.u.cl->backend_decl;
-      gcc_assert (expr1->ts.u.cl->backend_decl);
-      tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
-      gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      if (expr2->ts.deferred)
+	{
+	  if (TREE_CODE (expr2->ts.u.cl->backend_decl) == VAR_DECL)
+	    tmp = expr2->ts.u.cl->backend_decl;
+	  else
+	    tmp = rss->info->string_length;
+	}
+      else
+	{
+	  tmp = expr2->ts.u.cl->backend_decl;
+	  tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+	}
+
+      if (expr1->ts.u.cl->backend_decl
+	  && TREE_CODE (expr1->ts.u.cl->backend_decl) == VAR_DECL)
+	gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+      else
+	gfc_add_modify (&fblock, lss->info->string_length, tmp);
     }
   else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
     {