re PR fortran/41478 (Corrupted memory using PACK for derived-types with allocated components)

2010-01-14  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/41478
        * trans-array.c (duplicate_allocatable):  Static version of
	gfc_duplicate_allocatable with provision to handle scalar
	components. New boolean argument to switch off call to malloc
	if true.
	(gfc_duplicate_allocatable): New function to call above with
	new argument false.
	(gfc_copy_allocatable_data): New function to call above with
	new argument true.
	(structure_alloc_comps): Do not apply indirect reference to
	scalar pointers. Add new section to copy allocatable components
	of arrays. Extend copying of allocatable components to include
	scalars.
	(gfc_copy_only_alloc_comp): New function to copy allocatable
	component derived types, without allocating the base structure.
	* trans-array.h : Add primitive for gfc_copy_allocatable_data.
	Add primitive for gfc_copy_only_alloc_comp.
	* trans-expr.c (gfc_conv_procedure_call): After calls to
	transformational functions with results that are derived types
	with allocatable components, copy the components in the result.
	(gfc_trans_arrayfunc_assign): Deallocate allocatable components
	of lhs derived types before allocation.
	

2010-01-14  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/41478
        * gfortran.dg/alloc_comp_scalar_1.f90: New test.
        * gfortran.dg/alloc_comp_transformational_1.f90: New test.

From-SVN: r155877

gcc/fortran/ChangeLog

 2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
 
+        PR fortran/41478
+        * trans-array.c (duplicate_allocatable):  Static version of
+	gfc_duplicate_allocatable with provision to handle scalar
+	components. New boolean argument to switch off call to malloc
+	if true.
+	(gfc_duplicate_allocatable): New function to call above with
+	new argument false.
+	(gfc_copy_allocatable_data): New function to call above with
+	new argument true.
+	(structure_alloc_comps): Do not apply indirect reference to
+	scalar pointers. Add new section to copy allocatable components
+	of arrays. Extend copying of allocatable components to include
+	scalars.
+	(gfc_copy_only_alloc_comp): New function to copy allocatable
+	component derived types, without allocating the base structure.
+	* trans-array.h : Add primitive for gfc_copy_allocatable_data.
+	Add primitive for gfc_copy_only_alloc_comp.
+	* trans-expr.c (gfc_conv_procedure_call): After calls to
+	transformational functions with results that are derived types
+	with allocatable components, copy the components in the result.
+	(gfc_trans_arrayfunc_assign): Deallocate allocatable components
+	of lhs derived types before allocation.
+	
+2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/42481
 	* module.c (load_generic_interfaces): If a procedure that is
 	use associated but not generic is given an interface that

gcc/fortran/trans-array.c

@@ -5711,10 +5711,12 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank)
 }
 
 
-/* Allocate dest to the same size as src, and copy src -> dest.  */
+/* Allocate dest to the same size as src, and copy src -> dest.
+   If no_malloc is set, only the copy is done.  */
 
-tree
-gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
+static tree
+duplicate_allocatable(tree dest, tree src, tree type, int rank,
+		      bool no_malloc)
 {
   tree tmp;
   tree size;
@@ -5723,35 +5725,66 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
   tree null_data;
   stmtblock_t block;
 
-  /* If the source is null, set the destination to null.  */
+  /* If the source is null, set the destination to null.  Then,
+     allocate memory to the destination.  */
   gfc_init_block (&block);
-  gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
-  null_data = gfc_finish_block (&block);
 
-  gfc_init_block (&block);
+  if (rank == 0)
+    {
+      tmp = null_pointer_node;
+      tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
+      gfc_add_expr_to_block (&block, tmp);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      size = TYPE_SIZE_UNIT (type);
+      if (!no_malloc)
+	{
+	  tmp = gfc_call_malloc (&block, type, size);
+	  tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
+			     fold_convert (type, tmp));
+	  gfc_add_expr_to_block (&block, tmp);
+	}
+
+      tmp = built_in_decls[BUILT_IN_MEMCPY];
+      tmp = build_call_expr_loc (input_location, tmp, 3,
+				 dest, src, size);
+    }
+  else
+    {
+      gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+      null_data = gfc_finish_block (&block);
+
+      gfc_init_block (&block);
+      nelems = get_full_array_size (&block, src, rank);
+      tmp = fold_convert (gfc_array_index_type,
+			  TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+      size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
+      if (!no_malloc)
+	{
+	  tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
+	  tmp = gfc_call_malloc (&block, tmp, size);
+	  gfc_conv_descriptor_data_set (&block, dest, tmp);
+	}
+
+      /* We know the temporary and the value will be the same length,
+	 so can use memcpy.  */
+      tmp = built_in_decls[BUILT_IN_MEMCPY];
+      tmp = build_call_expr_loc (input_location,
+			tmp, 3, gfc_conv_descriptor_data_get (dest),
+			gfc_conv_descriptor_data_get (src), size);
+    }
 
-  nelems = get_full_array_size (&block, src, rank);
-  size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
-		      fold_convert (gfc_array_index_type,
-				    TYPE_SIZE_UNIT (gfc_get_element_type (type))));
-
-  /* Allocate memory to the destination.  */
-  tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
-			 size);
-  gfc_conv_descriptor_data_set (&block, dest, tmp);
-
-  /* We know the temporary and the value will be the same length,
-     so can use memcpy.  */
-  tmp = built_in_decls[BUILT_IN_MEMCPY];
-  tmp = build_call_expr_loc (input_location,
-			 tmp, 3, gfc_conv_descriptor_data_get (dest),
-  			 gfc_conv_descriptor_data_get (src), size);
   gfc_add_expr_to_block (&block, tmp);
   tmp = gfc_finish_block (&block);
 
   /* Null the destination if the source is null; otherwise do
      the allocate and copy.  */
-  null_cond = gfc_conv_descriptor_data_get (src);
+  if (rank == 0)
+    null_cond = src;
+  else
+    null_cond = gfc_conv_descriptor_data_get (src);
+
   null_cond = convert (pvoid_type_node, null_cond);
   null_cond = fold_build2 (NE_EXPR, boolean_type_node,
 			   null_cond, null_pointer_node);
@@ -5759,11 +5792,30 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
 }
 
 
+/* Allocate dest to the same size as src, and copy data src -> dest.  */
+
+tree
+gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable(dest, src, type, rank, false);
+}
+
+
+/* Copy data src -> dest.  */
+
+tree
+gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+{
+  return duplicate_allocatable(dest, src, type, rank, true);
+}
+
+
 /* Recursively traverse an object of derived type, generating code to
    deallocate, nullify or copy allocatable components.  This is the work horse
    function for the functions named in this enum.  */
 
-enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
+enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
+      COPY_ONLY_ALLOC_COMP};
 
 static tree
 structure_alloc_comps (gfc_symbol * der_type, tree decl,
@@ -5786,7 +5838,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
   gfc_init_block (&fnblock);
 
-  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+  if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
     decl = build_fold_indirect_ref_loc (input_location,
 				    decl);
 
@@ -5841,6 +5893,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 	  dref = gfc_build_array_ref (tmp, index, NULL);
 	  tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
 	}
+      else if (purpose == COPY_ONLY_ALLOC_COMP)
+        {
+	  tmp = build_fold_indirect_ref_loc (input_location,
+					 gfc_conv_array_data (dest));
+	  dref = gfc_build_array_ref (tmp, index, NULL);
+	  tmp = structure_alloc_comps (der_type, vref, dref, rank,
+				       COPY_ALLOC_COMP);
+	}
       else
         tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
 
@@ -5978,7 +6038,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
 
 	  if (c->attr.allocatable && !cmp_has_alloc_comps)
 	    {
-	      tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
+	      rank = c->as ? c->as->rank : 0;
+	      tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
 	      gfc_add_expr_to_block (&fnblock, tmp);
 	    }
 
@@ -6025,7 +6086,7 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank)
 
 
 /* Recursively traverse an object of derived type, generating code to
-   copy its allocatable components.  */
+   copy it and its allocatable components.  */
 
 tree
 gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
@@ -6034,6 +6095,16 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
 }
 
 
+/* Recursively traverse an object of derived type, generating code to
+   copy only its allocatable components.  */
+
+tree
+gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+{
+  return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+}
+
+
 /* NULLIFY an allocatable/pointer array on function entry, free it on exit.
    Do likewise, recursively if necessary, with the allocatable components of
    derived types.  */

gcc/fortran/trans-array.h

@@ -45,7 +45,9 @@ tree gfc_trans_g77_array (gfc_symbol *, tree);
 /* Generate code to deallocate an array, if it is allocated.  */
 tree gfc_trans_dealloc_allocated (tree);
 
-tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank);
+tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
+
+tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
 
 tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
 
@@ -53,6 +55,8 @@ tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
 
 tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
 
+tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+
 /* Add initialization for deferred arrays.  */
 tree gfc_trans_deferred_array (gfc_symbol *, tree);
 /* Generate an initializer for a static pointer or allocatable array.  */

gcc/fortran/trans-expr.c

@@ -2757,6 +2757,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   tree var;
   tree len;
   tree stringargs;
+  tree result = NULL;
   gfc_formal_arglist *formal;
   int has_alternate_specifier = 0;
   bool need_interface_mapping;
@@ -3288,6 +3289,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    se->expr = build_fold_indirect_ref_loc (input_location,
 						se->expr);
 
+	  result = build_fold_indirect_ref_loc (input_location,
+						se->expr);
 	  retargs = gfc_chainon_list (retargs, se->expr);
 	}
       else if (comp && comp->attr.dimension)
@@ -3310,8 +3313,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				       callee_alloc, &se->ss->expr->where);
 
 	  /* Pass the temporary as the first argument.  */
-	  tmp = info->descriptor;
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
 	  retargs = gfc_chainon_list (retargs, tmp);
 	}
       else if (!comp && sym->result->attr.dimension)
@@ -3334,8 +3337,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				       callee_alloc, &se->ss->expr->where);
 
 	  /* Pass the temporary as the first argument.  */
-	  tmp = info->descriptor;
-	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	  result = info->descriptor;
+	  tmp = gfc_build_addr_expr (NULL_TREE, result);
 	  retargs = gfc_chainon_list (retargs, tmp);
 	}
       else if (ts.type == BT_CHARACTER)
@@ -3487,7 +3490,36 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   /* Follow the function call with the argument post block.  */
   if (byref)
-    gfc_add_block_to_block (&se->pre, &post);
+    {
+      gfc_add_block_to_block (&se->pre, &post);
+
+      /* Transformational functions of derived types with allocatable
+         components must have the result allocatable components copied.  */
+      arg = expr->value.function.actual;
+      if (result && arg && expr->rank
+	    && expr->value.function.isym
+	    && expr->value.function.isym->transformational
+	    && arg->expr->ts.type == BT_DERIVED
+	    && arg->expr->ts.u.derived->attr.alloc_comp)
+	{
+	  tree tmp2;
+	  /* Copy the allocatable components.  We have to use a
+	     temporary here to prevent source allocatable components
+	     from being corrupted.  */
+	  tmp2 = gfc_evaluate_now (result, &se->pre);
+	  tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
+				     result, tmp2, expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	  tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
+				           expr->rank);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+
+	  /* Finally free the temporary's data field.  */
+	  tmp = gfc_conv_descriptor_data_get (tmp2);
+	  tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+    }
   else
     gfc_add_block_to_block (&se->post, &post);
 
@@ -4906,6 +4938,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
 
+  if (expr1->ts.type == BT_DERIVED
+	&& expr1->ts.u.derived->attr.alloc_comp)
+    {
+      tree tmp;
+      tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+				       expr1->rank);
+      gfc_add_expr_to_block (&se.pre, tmp);
+    }
+
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
   gcc_assert (se.ss != gfc_ss_terminator);

gcc/testsuite/ChangeLog

 2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
 
+        PR fortran/41478
+        * gfortran.dg/alloc_comp_scalar_1.f90: New test.
+        * gfortran.dg/alloc_comp_transformational_1.f90: New test.
+
+2010-01-14  Paul Thomas  <pault@gcc.gnu.org>
+
 	PR fortran/42481
 	* gfortran.dg/generic_19.f90 : New test.
 

gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90

+! { dg-do run }
+! Test the fix for comment #8 of PR41478, in which copying
+! allocatable scalar components caused a segfault.
+! 
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+program main
+  type :: container_t
+    integer, allocatable :: entry
+  end type container_t
+  type(container_t), dimension(1) :: a1, a2
+  allocate (a1(1)%entry, a2(1)%entry)
+  a2(1)%entry = 1
+  a1(1:1) = pack (a2(1:1), mask = [.true.])
+  deallocate (a2(1)%entry)
+  if (a1(1)%entry .ne. 1) call abort
+end program main

gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90

+! { dg-do run }
+! Tests the fix for PR41478, in which double frees would occur because
+! transformational intrinsics did not copy the allocatable components
+! so that they were (sometimes) freed twice on exit.  In addition,
+! The original allocatable components of a1 were not freed, so that
+! memory leakage occurred.
+!
+! Contributed by Juergen Reuter <reuter@physik.uni-freiburg.de>
+!
+  type :: container_t
+    integer, dimension(:), allocatable :: entry
+    integer index
+  end type container_t
+  call foo
+  call bar
+contains
+!
+! This is the reported problem.
+!
+  subroutine foo
+    type(container_t), dimension(4) :: a1, a2, a3
+    integer :: i
+    do i = 1, 4
+      allocate (a1(i)%entry (2), a2(i)%entry (2), a3(i)%entry (2))
+      a1(i)%entry = [1,2]
+      a2(i)%entry = [3,4]
+      a3(i)%entry = [4,5]
+      a1(i)%index = i
+      a2(i)%index = i
+      a3(i)%index = i
+    end do
+    a1(1:2) = pack (a2, [.true., .false., .true., .false.])
+    do i = 1, 4
+      if (.not.allocated (a1(i)%entry)) call abort
+      if (i .gt. 2) then
+        if (any (a1(i)%entry .ne. [1,2])) call abort
+      else
+        if (any (a1(i)%entry .ne. [3,4])) call abort
+      end if
+    end do
+!
+! Now check unpack
+!
+    a1 = unpack (a1, [.true., .true., .false., .false.], a3)
+    if (any (a1%index .ne. [1,3,3,4])) call abort
+    do i = 1, 4
+      if (.not.allocated (a1(i)%entry)) call abort
+      if (i .gt. 2) then
+        if (any (a1(i)%entry .ne. [4,5])) call abort
+      else
+        if (any (a1(i)%entry .ne. [3,4])) call abort
+      end if
+    end do
+  end subroutine
+!
+! Other all transformational intrinsics display it. Having done
+! PACK and UNPACK, just use TRANSPOSE as a demonstrator.
+!
+  subroutine bar
+    type(container_t), dimension(2,2) :: a1, a2
+    integer :: i, j
+    do i = 1, 2
+      do j = 1, 2
+        allocate (a1(i, j)%entry (2), a2(i, j)%entry (2))
+        a1(i, j)%entry = [i,j]
+        a2(i, j)%entry = [i,j]
+        a1(i,j)%index = j + (i - 1)*2
+        a2(i,j)%index = j + (i - 1)*2
+      end do
+    end do
+    a1 = transpose (a2)
+    do i = 1, 2
+      do j = 1, 2
+        if (a1(i,j)%index .ne. i + (j - 1)*2) call abort
+        if (any (a1(i,j)%entry .ne. [j,i])) call abort
+      end do
+    end do
+  end subroutine
+end
+