re PR fortran/83611 ([PDT] Assignment of parameterized types causes double free error in runtime)

2018-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83611
	* decl.c (gfc_get_pdt_instance): If parameterized arrays have
	an initializer, convert the kind parameters and add to the
	component if the instance.
	* trans-array.c (structure_alloc_comps): Add 'is_pdt_type' and
	use it with case COPY_ALLOC_COMP. Call 'duplicate_allocatable'
	for parameterized arrays. Clean up typos in comments. Convert
	parameterized array initializers and copy into the array.
	* trans-expr.c (gfc_trans_scalar_assign): Do a deep copy for
	parameterized types.
	*trans-stmt.c (trans_associate_var): Deallocate associate vars
	as necessary, when they are PDT function results for example.

	PR fortran/83731
	* trans-array.c (structure_alloc_comps): Only compare len parms
	when they are declared explicitly.

2018-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/83611
	* gfortran.dg/pdt_15.f03 : Bump count of 'n.data = 0B' to 8.
	* gfortran.dg/pdt_26.f03 : Bump count of '_malloc' to 9.
	* gfortran.dg/pdt_27.f03 : New test.

	PR fortran/83731
	* gfortran.dg/pdt_28.f03 : New test.

From-SVN: r256335

1 files changed, 37 insertions, 9 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b8e31bb..474a7d1 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8450,6 +8450,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
       bool same_type = (c->ts.type == BT_DERIVED && der_type == c->ts.u.derived)
 	|| (c->ts.type == BT_CLASS && der_type == CLASS_DATA (c)->ts.u.derived);
 
+      bool is_pdt_type = c->ts.type == BT_DERIVED
+			 && c->ts.u.derived->attr.pdt_type;
+
       cdecl = c->backend_decl;
       ctype = TREE_TYPE (cdecl);
 
@@ -8909,8 +8912,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	     components that are really allocated, the deep copy code has to
 	     be generated first and then added to the if-block in
 	     gfc_duplicate_allocatable ().  */
-	  if (cmp_has_alloc_comps && !c->attr.proc_pointer
-	      && !same_type)
+	  if (cmp_has_alloc_comps && !c->attr.proc_pointer && !same_type)
 	    {
 	      rank = c->as ? c->as->rank : 0;
 	      tmp = fold_convert (TREE_TYPE (dcmp), comp);
@@ -8944,9 +8946,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 					   false, false, size, NULL_TREE);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
-	  else if (c->attr.allocatable && !c->attr.proc_pointer && !same_type
-		   && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
-		       || caf_in_coarray (caf_mode)))
+	  else if (c->attr.pdt_array)
+	    {
+	      tmp = duplicate_allocatable (dcmp, comp, ctype,
+					   c->as ? c->as->rank : 0,
+					   false, false, NULL_TREE, NULL_TREE);
+	      gfc_add_expr_to_block (&fnblock, tmp);
+	    }
+	  else if ((c->attr.allocatable)
+		    && !c->attr.proc_pointer && !same_type
+		    && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension
+			|| caf_in_coarray (caf_mode)))
 	    {
 	      rank = c->as ? c->as->rank : 0;
 	      if (c->attr.codimension)
@@ -8969,7 +8979,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 	  else
-	    if (cmp_has_alloc_comps)
+	    if (cmp_has_alloc_comps || is_pdt_type)
 	      gfc_add_expr_to_block (&fnblock, add_when_allocated);
 
 	  break;
@@ -9022,7 +9032,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		}
 	      gfc_free_expr (e);
 
-	      /* Scalar parameterizied strings can be allocated now.  */
+	      /* Scalar parameterized strings can be allocated now.  */
 	      if (!c->as)
 		{
 		  tmp = fold_convert (gfc_array_index_type, strlen);
@@ -9033,7 +9043,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 		}
 	    }
 
-	  /* Allocate paramterized arrays of parameterized derived types.  */
+	  /* Allocate parameterized arrays of parameterized derived types.  */
 	  if (!(c->attr.pdt_array && c->as && c->as->type == AS_EXPLICIT)
 	      && !((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
 		   && (c->ts.u.derived && c->ts.u.derived->attr.pdt_type)))
@@ -9111,6 +9121,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	      gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
 	      tmp = gfc_conv_descriptor_dtype (comp);
 	      gfc_add_modify (&fnblock, tmp, gfc_get_dtype (ctype));
+
+	      if (c->initializer && c->initializer->rank)
+		{
+		  gfc_init_se (&tse, NULL);
+		  e = gfc_copy_expr (c->initializer);
+		  gfc_insert_parameter_exprs (e, pdt_param_list);
+		  gfc_conv_expr_descriptor (&tse, e);
+		  gfc_add_block_to_block (&fnblock, &tse.pre);
+		  gfc_free_expr (e);
+		  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+		  tmp = build_call_expr_loc (input_location, tmp, 3,
+				     gfc_conv_descriptor_data_get (comp),
+				     gfc_conv_descriptor_data_get (tse.expr),
+				     fold_convert (size_type_node, size));
+		  gfc_add_expr_to_block (&fnblock, tmp);
+		  gfc_add_block_to_block (&fnblock, &tse.post);
+		}
 	    }
 
 	  /* Recurse in to PDT components.  */
@@ -9212,7 +9239,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	      gfc_init_se (&tse, NULL);
 	      for (; param; param = param->next)
-		if (!strcmp (c->name, param->name))
+		if (!strcmp (c->name, param->name)
+		    && param->spec_type == SPEC_EXPLICIT)
 		  c_expr = param->expr;
 
 	      if (c_expr)