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

10 files changed, 163 insertions, 14 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 59ce3d0d..d150f67 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+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-06  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	PR fortran/50892
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a944e4f..cb23534 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3562,6 +3562,12 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	      c2->as->upper[i] = e;
 	    }
 	  c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+	  if (c1->initializer)
+	    {
+	      c2->initializer = gfc_copy_expr (c1->initializer);
+	      gfc_insert_kind_parameter_exprs (c2->initializer);
+	      gfc_simplify_expr (c2->initializer, 1);
+	    }
 	}
 
       /* Recurse into this function for PDT components.  */
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)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 82fe424..add0d69 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -8826,7 +8826,9 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
 			     rse->expr, ts.kind);
     }
-  else if (gfc_bt_struct (ts.type) && ts.u.derived->attr.alloc_comp)
+  else if (gfc_bt_struct (ts.type)
+	   && (ts.u.derived->attr.alloc_comp
+		|| (deep_copy && ts.u.derived->attr.pdt_type)))
     {
       tree tmp_var = NULL_TREE;
       cond = NULL_TREE;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 74974d3..ff6e591 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1634,6 +1634,16 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
 	  gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
 	}
 
+      if (e->expr_type == EXPR_FUNCTION
+	  && sym->ts.type == BT_DERIVED
+	  && sym->ts.u.derived
+	  && sym->ts.u.derived->attr.pdt_type)
+	{
+	  tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
+					 sym->as->rank);
+	  gfc_add_expr_to_block (&se.post, tmp);
+	}
+
       /* Done, register stuff as init / cleanup code.  */
       gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
 			    gfc_finish_block (&se.post));
@@ -1810,10 +1820,31 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   else
     {
       gfc_expr *lhs;
+      tree res;
 
       lhs = gfc_lval_expr_from_sym (sym);
-      tmp = gfc_trans_assignment (lhs, e, false, true);
-      gfc_add_init_cleanup (block, tmp, NULL_TREE);
+      res = gfc_trans_assignment (lhs, e, false, true);
+
+      tmp = sym->backend_decl;
+      if (e->expr_type == EXPR_FUNCTION
+	  && sym->ts.type == BT_DERIVED
+	  && sym->ts.u.derived
+	  && sym->ts.u.derived->attr.pdt_type)
+	{
+	  tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
+					 0);
+	}
+      else if (e->expr_type == EXPR_FUNCTION
+	       && sym->ts.type == BT_CLASS
+	       && CLASS_DATA (sym)->ts.u.derived
+	       && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)
+	{
+	  tmp = gfc_class_data_get (tmp);
+	  tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
+					 tmp, 0);
+	}
+
+      gfc_add_init_cleanup (block, res, tmp);
     }
 
   /* Set the stringlength, when needed.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3a72d8d..4ff7051 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,13 @@
+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.
+
 2018-01-08  Tom de Vries  <tom@codesourcery.com>
 
 	* c-c++-common/builtins.c: Require effective target alloca.
diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03
index bbf140e..f2f0b67 100644
--- a/gcc/testsuite/gfortran.dg/pdt_15.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_15.f03
@@ -102,5 +102,5 @@ contains
   end subroutine
 end program ch2701
 ! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } }
-! { dg-final { scan-tree-dump-times ".n.data = 0B" 7 "original" } }
+! { dg-final { scan-tree-dump-times ".n.data = 0B" 8 "original" } }
 ! { dg-final { scan-tree-dump-times "__builtin_free" 14 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_26.f03 b/gcc/testsuite/gfortran.dg/pdt_26.f03
index a4819b0..01ed640 100644
--- a/gcc/testsuite/gfortran.dg/pdt_26.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_26.f03
@@ -43,4 +43,4 @@ program test_pdt
   if (any (c(1)%foo .ne. [13,15,17])) call abort
 end program test_pdt
 ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_malloc" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 9 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_27.f03 b/gcc/testsuite/gfortran.dg/pdt_27.f03
new file mode 100644
index 0000000..89eb63d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_27.f03
@@ -0,0 +1,22 @@
+! { dg-do run }
+!
+! Test the fix for PR83611, in which the assignment caused a
+! double free error and the initialization of 'foo' was not done.
+!
+module pdt_m
+  implicit none
+  type :: vec(k)
+     integer, len :: k=3
+     integer :: foo(k)=[1,2,3]
+  end type vec
+end module pdt_m
+
+program test_pdt
+  use pdt_m
+  implicit none
+  type(vec) :: u,v
+  if (any (u%foo .ne. [1,2,3])) call abort
+  u%foo = [7,8,9]
+  v = u
+  if (any (v%foo .ne. [7,8,9])) call abort
+end program test_pdt
diff --git a/gcc/testsuite/gfortran.dg/pdt_28.f03 b/gcc/testsuite/gfortran.dg/pdt_28.f03
new file mode 100644
index 0000000..da4c9d6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_28.f03
@@ -0,0 +1,31 @@
+! { dg-do run }
+! ( dg-options "-fbounds-check" }
+!
+! Test the fix for PR83731, where the following failed on the check for the
+! value of the parameter 'k'.
+!
+! Contributed by Berke Durak  <berke.durak@gmail.com>
+!
+module pdt_m
+  implicit none
+  type :: vec(k)
+     integer, len :: k=10
+     integer :: foo(k)
+  end type vec
+contains
+  function total(a)
+    type(vec(k=*)), intent(in) :: a ! Would compare with the default initializer.
+    integer :: total
+    
+    total=sum(a%foo)
+  end function total
+end module pdt_m
+
+program test_pdt
+  use pdt_m
+  implicit none
+  type(vec(k=123)) :: u
+
+  u%foo=1
+  if (total(u) .ne. u%k) call abort
+end program test_pdt