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
}
-/* 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;
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);
}
+/* 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,
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);
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);
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);
}
/* 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)
}
+/* 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. */
/* 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);
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. */
tree var;
tree len;
tree stringargs;
+ tree result = NULL;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
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)
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)
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)
/* 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);
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);
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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
OSDN Git Service
