trans-array.c (gfc_trans_dealloc_allocated): New function.
fortran/ 2005-03-06 Paul Thomas <pault@gcc.gnu.org> Erik Edelmann <eedelman@gcc.gnu.org> * trans-array.c (gfc_trans_dealloc_allocated): New function. (gfc_trans_deferred_array): Use it, instead of inline code. * trans-array.h: Prototype for gfc_trans_dealloc_allocated(). * trans-expr.c (gfc_conv_function_call): Deallocate allocated ALLOCATABLE, INTENT(OUT) arguments upon procedure entry. testsuite/ 2005-03-06 Paul Thomas <pault@gcc.gnu.org> Erik Edelmann <eedelman@gcc.gnu.org> * gfortran.dg/allocatable_dummy_1.f90: Take into account that INTENT(OUT) arguments shall be deallocated upon procedure entry. Co-Authored-By: Erik Edelmann <eedelman@gcc.gnu.org> From-SVN: r111795
This commit is contained in:
parent
c09a1bf1a2
commit
42a0e16c2d
|
@ -1,3 +1,12 @@
|
|||
2005-03-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
Erik Edelmann <eedelman@gcc.gnu.org>
|
||||
|
||||
* trans-array.c (gfc_trans_dealloc_allocated): New function.
|
||||
(gfc_trans_deferred_array): Use it, instead of inline code.
|
||||
* trans-array.h: Prototype for gfc_trans_dealloc_allocated().
|
||||
* trans-expr.c (gfc_conv_function_call): Deallocate allocated
|
||||
ALLOCATABLE, INTENT(OUT) arguments upon procedure entry.
|
||||
|
||||
2006-03-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/26107
|
||||
|
|
|
@ -4297,6 +4297,34 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
|
|||
}
|
||||
|
||||
|
||||
/* Generate code to deallocate the symbol 'sym', if it is allocated. */
|
||||
|
||||
tree
|
||||
gfc_trans_dealloc_allocated (gfc_symbol * sym)
|
||||
{
|
||||
tree tmp;
|
||||
tree descriptor;
|
||||
tree deallocate;
|
||||
stmtblock_t block;
|
||||
|
||||
gcc_assert (sym->attr.allocatable);
|
||||
|
||||
gfc_start_block (&block);
|
||||
descriptor = sym->backend_decl;
|
||||
deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
|
||||
|
||||
tmp = gfc_conv_descriptor_data_get (descriptor);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
|
||||
build_int_cst (TREE_TYPE (tmp), 0));
|
||||
tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
tmp = gfc_finish_block (&block);
|
||||
|
||||
return tmp;
|
||||
}
|
||||
|
||||
|
||||
/* NULLIFY an allocatable/pointer array on function entry, free it on exit. */
|
||||
|
||||
tree
|
||||
|
@ -4305,8 +4333,6 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
tree type;
|
||||
tree tmp;
|
||||
tree descriptor;
|
||||
tree deallocate;
|
||||
stmtblock_t block;
|
||||
stmtblock_t fnblock;
|
||||
locus loc;
|
||||
|
||||
|
@ -4359,18 +4385,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
|
|||
/* Allocatable arrays need to be freed when they go out of scope. */
|
||||
if (sym->attr.allocatable)
|
||||
{
|
||||
gfc_start_block (&block);
|
||||
|
||||
/* Deallocate if still allocated at the end of the procedure. */
|
||||
deallocate = gfc_array_deallocate (descriptor, null_pointer_node);
|
||||
|
||||
tmp = gfc_conv_descriptor_data_get (descriptor);
|
||||
tmp = build2 (NE_EXPR, boolean_type_node, tmp,
|
||||
build_int_cst (TREE_TYPE (tmp), 0));
|
||||
tmp = build3_v (COND_EXPR, tmp, deallocate, build_empty_stmt ());
|
||||
gfc_add_expr_to_block (&block, tmp);
|
||||
|
||||
tmp = gfc_finish_block (&block);
|
||||
tmp = gfc_trans_dealloc_allocated (sym);
|
||||
gfc_add_expr_to_block (&fnblock, tmp);
|
||||
}
|
||||
|
||||
|
|
|
@ -42,6 +42,8 @@ tree gfc_trans_auto_array_allocation (tree, gfc_symbol *, tree);
|
|||
tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree);
|
||||
/* Generate entry and exit code for g77 calling convention arrays. */
|
||||
tree gfc_trans_g77_array (gfc_symbol *, tree);
|
||||
/* Generate code to deallocate the symbol 'sym', if it is allocated. */
|
||||
tree gfc_trans_dealloc_allocated (gfc_symbol * sym);
|
||||
/* Add initialization for deferred arrays. */
|
||||
tree gfc_trans_deferred_array (gfc_symbol *, tree);
|
||||
/* Generate an initializer for a static pointer or allocatable array. */
|
||||
|
|
|
@ -1914,6 +1914,16 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
gfc_conv_aliased_arg (&parmse, arg->expr, f);
|
||||
else
|
||||
gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
|
||||
|
||||
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
|
||||
allocated on entry, it must be deallocated. */
|
||||
if (formal && formal->sym->attr.allocatable
|
||||
&& formal->sym->attr.intent == INTENT_OUT)
|
||||
{
|
||||
tmp = gfc_trans_dealloc_allocated (arg->expr->symtree->n.sym);
|
||||
gfc_add_expr_to_block (&se->pre, tmp);
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
2005-03-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
Erik Edelmann <eedelman@gcc.gnu.org>
|
||||
|
||||
* gfortran.dg/allocatable_dummy_1.f90: Take into account that
|
||||
INTENT(OUT) arguments shall be deallocated upon procedure entry.
|
||||
|
||||
2006-03-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/26107
|
||||
|
|
|
@ -4,29 +4,39 @@ program alloc_dummy
|
|||
|
||||
implicit none
|
||||
integer, allocatable :: a(:)
|
||||
integer, allocatable :: b(:)
|
||||
|
||||
call init(a)
|
||||
if (.NOT.allocated(a)) call abort()
|
||||
if (.NOT.all(a == [ 1, 2, 3 ])) call abort()
|
||||
|
||||
call useit(a, b)
|
||||
if (.NOT.all(b == [ 1, 2, 3 ])) call abort()
|
||||
|
||||
call kill(a)
|
||||
if (allocated(a)) call abort()
|
||||
|
||||
call kill(b)
|
||||
if (allocated(b)) call abort()
|
||||
|
||||
contains
|
||||
|
||||
subroutine init(x)
|
||||
integer, allocatable, intent(out) :: x(:)
|
||||
|
||||
allocate(x(3))
|
||||
x = [ 1, 2, 3 ]
|
||||
end subroutine init
|
||||
|
||||
|
||||
subroutine useit(x, y)
|
||||
integer, allocatable, intent(in) :: x(:)
|
||||
integer, allocatable, intent(out) :: y(:)
|
||||
if (allocated(y)) call abort()
|
||||
allocate (y(3))
|
||||
y = x
|
||||
end subroutine useit
|
||||
|
||||
subroutine kill(x)
|
||||
integer, allocatable, intent(out) :: x(:)
|
||||
|
||||
deallocate(x)
|
||||
end subroutine kill
|
||||
|
||||
end program alloc_dummy
|
||||
|
|
Loading…
Reference in New Issue