procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/42647 ([F03] Missed initialization/dealloc of allocatable scalar DT with allocatable component)

Browse source 
2010-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42647
	* trans.h (gfc_deallocate_scalar_with_status): New prototype.
	* trans.c (gfc_deallocate_scalar_with_status): New function for
	deallocation of allocatable scalars.
	* trans-array.c (structure_alloc_comps): Call it here ...
	* trans-decl.c (gfc_trans_deferred_vars): ... here ...
	* trans-stmt.c (gfc_trans_deallocate): ... and here.

2010-10-26  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42647
	* gfortran.dg/allocatable_scalar_9.f90: Extended.
	* gfortran.dg/allocatable_scalar_10.f90: New.
	* gfortran.dg/class_19.f03: Extended.

From-SVN: r165973
This commit is contained in:
Janus Weil 2010-10-26 19:38:42 +02:00
parent 530f3a1bf6
commit 2c80712872
10 changed files with 176 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View file

@ -1,3 +1,13 @@
2010-10-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/42647
* trans.h (gfc_deallocate_scalar_with_status): New prototype.
* trans.c (gfc_deallocate_scalar_with_status): New function for
deallocation of allocatable scalars.
* trans-array.c (structure_alloc_comps): Call it here ...
* trans-decl.c (gfc_trans_deferred_vars): ... here ...
* trans-stmt.c (gfc_trans_deallocate): ... and here.
2010-10-26 Tobias Burnus <burnus@net-b.de>
PR fortran/45451

26
gcc/fortran/trans-array.c
View file

@ -6281,22 +6281,18 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
/* Do not deallocate the components of ultimate pointer
components. */
if (cmp_has_alloc_comps && !c->attr.pointer)
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
if (c->attr.allocatable && c->attr.dimension)
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
if (cmp_has_alloc_comps && !c->attr.pointer)
{
/* Do not deallocate the components of ultimate pointer
components. */
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
c->as->rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
@ -6306,7 +6302,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
c->ts);
gfc_add_expr_to_block (&fnblock, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@ -6325,7 +6322,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
comp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
tmp = gfc_deallocate_with_status (comp, NULL_TREE, true, NULL);
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
CLASS_DATA (c)->ts);
gfc_add_expr_to_block (&fnblock, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,

7
gcc/fortran/trans-decl.c
View file

@ -3408,10 +3408,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
/* Deallocate when leaving the scope. Nullifying is not
needed. */
tmp = NULL;
if (!sym->attr.result)
tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
true, NULL);
tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
NULL, sym->ts);
else
tmp = NULL;
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}

44
gcc/fortran/trans-stmt.c
View file

@ -4676,30 +4676,32 @@ gfc_trans_deallocate (gfc_code *code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
/* Do not deallocate the components of a derived type
ultimate pointer component. */
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
if (expr->rank)
tmp = gfc_array_deallocate (se.expr, pstat, expr);
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{
gfc_ref *ref;
gfc_ref *last = NULL;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
last = ref;
/* Do not deallocate the components of a derived type
ultimate pointer component. */
if (!(last && last->u.c.component->attr.pointer)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
tmp = gfc_array_deallocate (se.expr, pstat, expr);
}
else
{
tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
expr, expr->ts);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,

97
gcc/fortran/trans.c
View file

@ -945,6 +945,103 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
}
/* Generate code for deallocation of allocatable scalars (variables or
components). Before the object itself is freed, any allocatable
subcomponents are being deallocated. */
tree
gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
gfc_expr* expr, gfc_typespec ts)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
/* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
we emit a runtime error. */
gfc_start_block (&null);
if (!can_fail)
{
tree varname;
gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
varname = gfc_build_cstring_const (expr->symtree->name);
varname = gfc_build_addr_expr (pchar_type_node, varname);
error = gfc_trans_runtime_error (true, &expr->where,
"Attempt to DEALLOCATE unallocated '%s'",
varname);
}
else
error = build_empty_stmt (input_location);
if (status != NULL_TREE && !integer_zerop (status))
{
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
build_int_cst (status_type, 1));
error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond2, tmp, error);
}
gfc_add_expr_to_block (&null, error);
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
/* Free allocatable components. */
if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
else if (ts.type == BT_CLASS
&& ts.u.derived->components->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, pointer);
tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
tmp, 0);
gfc_add_expr_to_block (&non_null, tmp);
}
tmp = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_FREE], 1,
fold_convert (pvoid_type_node, pointer));
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
{
/* We set STATUS to zero if it is present. */
tree status_type = TREE_TYPE (TREE_TYPE (status));
tree cond2;
cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
status, build_int_cst (TREE_TYPE (status), 0));
tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
build_int_cst (status_type, 0));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&non_null, tmp);
}
return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
gfc_finish_block (&null),
gfc_finish_block (&non_null));
}
/* Reallocate MEM so it has SIZE bytes of data. This behaves like the
following pseudo-code:

1
gcc/fortran/trans.h
View file

@ -532,6 +532,7 @@ tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
tree gfc_deallocate_scalar_with_status (tree, tree, bool, gfc_expr*, gfc_typespec);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
2010-10-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/42647
* gfortran.dg/allocatable_scalar_9.f90: Extended.
* gfortran.dg/allocatable_scalar_10.f90: New.
* gfortran.dg/class_19.f03: Extended.
2010-10-26 Jan Hubicka <jh@suse.cz>
PR middle-end/45736

14
gcc/testsuite/gfortran.dg/allocatable_scalar_10.f90 Normal file
View file

@ -0,0 +1,14 @@
! { dg-do run }
!
! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
type t
integer, allocatable :: p
end type t
type(t), allocatable :: a
deallocate(a,stat=istat)
if (istat == 0) call abort()
end

4
gcc/testsuite/gfortran.dg/allocatable_scalar_9.f90
View file

@ -1,4 +1,5 @@
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component
!
@ -48,4 +49,7 @@ if(allocated(na3%b3)) call abort()
if(allocated(na4%b4)) call abort()
end
! { dg-final { scan-tree-dump-times "__builtin_free" 32 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "m" } }

4
gcc/testsuite/gfortran.dg/class_19.f03
View file

@ -1,4 +1,5 @@
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR 43969: [OOP] ALLOCATED() with polymorphic variables
!
@ -38,4 +39,7 @@ program main
end program main
! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-modules "foo_mod" } }