re PR fortran/37336 ([F03] Finish derived-type finalization)
2013-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans.c (gfc_add_comp_finalizer_call): New function.
* trans.h (gfc_add_comp_finalizer_call): New prototype.
* trans-array.c (structure_alloc_comps): Call it.
2013-07-15 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.dg/finalize_18.f90: New.
From-SVN: r200954
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
0768ca33ac
commit
895a0c2df3
6 changed files with 179 additions and 6 deletions
|
|
@ -1,3 +1,10 @@
|
|||
2013-07-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/37336
|
||||
* trans.c (gfc_add_comp_finalizer_call): New function.
|
||||
* trans.h (gfc_add_comp_finalizer_call): New prototype.
|
||||
* trans-array.c (structure_alloc_comps): Call it.
|
||||
|
||||
2013-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
|
|
|
|||
|
|
@ -7584,19 +7584,34 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
called_dealloc_with_status = false;
|
||||
gfc_init_block (&tmpblock);
|
||||
|
||||
if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
|
||||
&& !c->attr.proc_pointer)
|
||||
if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
|
||||
|| (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
|
||||
{
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
||||
/* The finalizer frees allocatable components. */
|
||||
called_dealloc_with_status
|
||||
= gfc_add_comp_finalizer_call (&tmpblock, comp, c, true);
|
||||
}
|
||||
else
|
||||
comp = NULL_TREE;
|
||||
|
||||
if (c->attr.allocatable && (c->attr.dimension || c->attr.codimension)
|
||||
&& !c->attr.proc_pointer)
|
||||
{
|
||||
if (comp == NULL_TREE)
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
|
||||
gfc_add_expr_to_block (&tmpblock, tmp);
|
||||
}
|
||||
else if (c->attr.allocatable)
|
||||
{
|
||||
/* Allocatable scalar components. */
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
if (comp == NULL_TREE)
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
||||
tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL,
|
||||
c->ts);
|
||||
|
|
@ -7611,10 +7626,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
|
||||
{
|
||||
/* Allocatable CLASS components. */
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
||||
/* Add reference to '_data' component. */
|
||||
if (comp == NULL_TREE)
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
tmp = CLASS_DATA (c)->backend_decl;
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF,
|
||||
TREE_TYPE (tmp), comp, tmp, NULL_TREE);
|
||||
|
|
|
|||
|
|
@ -948,6 +948,102 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
|
|||
}
|
||||
|
||||
|
||||
bool
|
||||
gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp,
|
||||
bool fini_coarray)
|
||||
{
|
||||
gfc_se se;
|
||||
stmtblock_t block2;
|
||||
tree final_fndecl, size, array, tmp, cond;
|
||||
symbol_attribute attr;
|
||||
gfc_expr *final_expr = NULL;
|
||||
|
||||
if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS)
|
||||
return false;
|
||||
|
||||
gfc_init_block (&block2);
|
||||
|
||||
if (comp->ts.type == BT_DERIVED)
|
||||
{
|
||||
if (comp->attr.pointer)
|
||||
return false;
|
||||
|
||||
gfc_is_finalizable (comp->ts.u.derived, &final_expr);
|
||||
if (!final_expr)
|
||||
return false;
|
||||
|
||||
gfc_init_se (&se, NULL);
|
||||
gfc_conv_expr (&se, final_expr);
|
||||
final_fndecl = se.expr;
|
||||
size = gfc_typenode_for_spec (&comp->ts);
|
||||
size = TYPE_SIZE_UNIT (size);
|
||||
size = fold_convert (gfc_array_index_type, size);
|
||||
|
||||
array = decl;
|
||||
}
|
||||
else /* comp->ts.type == BT_CLASS. */
|
||||
{
|
||||
if (CLASS_DATA (comp)->attr.class_pointer)
|
||||
return false;
|
||||
|
||||
gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr);
|
||||
final_fndecl = gfc_vtable_final_get (decl);
|
||||
size = gfc_vtable_size_get (decl);
|
||||
array = gfc_class_data_get (decl);
|
||||
}
|
||||
|
||||
if (comp->attr.allocatable
|
||||
|| (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable))
|
||||
{
|
||||
tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))
|
||||
? gfc_conv_descriptor_data_get (array) : array;
|
||||
cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||||
tmp, fold_convert (TREE_TYPE (tmp),
|
||||
null_pointer_node));
|
||||
}
|
||||
else
|
||||
cond = boolean_true_node;
|
||||
|
||||
if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
|
||||
{
|
||||
gfc_clear_attr (&attr);
|
||||
gfc_init_se (&se, NULL);
|
||||
array = gfc_conv_scalar_to_descriptor (&se, array, attr);
|
||||
gfc_add_block_to_block (&block2, &se.pre);
|
||||
gcc_assert (se.post.head == NULL_TREE);
|
||||
}
|
||||
|
||||
if (!POINTER_TYPE_P (TREE_TYPE (array)))
|
||||
array = gfc_build_addr_expr (NULL, array);
|
||||
|
||||
if (!final_expr)
|
||||
{
|
||||
tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
|
||||
final_fndecl,
|
||||
fold_convert (TREE_TYPE (final_fndecl),
|
||||
null_pointer_node));
|
||||
cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
|
||||
boolean_type_node, cond, tmp);
|
||||
}
|
||||
|
||||
if (POINTER_TYPE_P (TREE_TYPE (final_fndecl)))
|
||||
final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl);
|
||||
|
||||
tmp = build_call_expr_loc (input_location,
|
||||
final_fndecl, 3, array,
|
||||
size, fini_coarray ? boolean_true_node
|
||||
: boolean_false_node);
|
||||
gfc_add_expr_to_block (&block2, tmp);
|
||||
tmp = gfc_finish_block (&block2);
|
||||
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (block, tmp);
|
||||
|
||||
return true;
|
||||
}
|
||||
|
||||
|
||||
/* Add a call to the finalizer, using the passed *expr. Returns
|
||||
true when a finalizer call has been inserted. */
|
||||
|
||||
|
|
|
|||
|
|
@ -353,6 +353,8 @@ tree gfc_get_vptr_from_expr (tree);
|
|||
tree gfc_get_class_array_ref (tree, tree);
|
||||
tree gfc_copy_class_to_class (tree, tree, tree);
|
||||
bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
|
||||
bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
|
||||
|
||||
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_typespec, tree, bool,
|
||||
bool);
|
||||
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2013-07-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/37336
|
||||
* gfortran.dg/finalize_18.f90: New.
|
||||
|
||||
2013-07-14 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/52669
|
||||
|
|
|
|||
47
gcc/testsuite/gfortran.dg/finalize_18.f90
Normal file
47
gcc/testsuite/gfortran.dg/finalize_18.f90
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-fdump-tree-original" }
|
||||
!
|
||||
! PR fortran/37336
|
||||
!
|
||||
module m
|
||||
type t
|
||||
contains
|
||||
final :: fini
|
||||
end type t
|
||||
type t2
|
||||
integer :: ii
|
||||
type(t), allocatable :: aa
|
||||
type(t), allocatable :: bb(:)
|
||||
class(t), allocatable :: cc
|
||||
class(t), allocatable :: dd(:)
|
||||
end type t2
|
||||
integer, save :: cnt = -1
|
||||
contains
|
||||
subroutine fini(x)
|
||||
type(t) :: x
|
||||
if (cnt == -1) call abort ()
|
||||
cnt = cnt + 1
|
||||
end subroutine fini
|
||||
end module m
|
||||
|
||||
use m
|
||||
block
|
||||
type(t2) :: y
|
||||
y%ii = 123
|
||||
end block
|
||||
end
|
||||
|
||||
! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.\[0-9\]+, 0, 1\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump "y.cc._vptr->_final \\(&desc.\[0-9\]+, (\\(integer\\(kind=8\\)\\) )?y.cc._vptr->_size, 1\\);" "original" } }
|
||||
! { dg-final { scan-tree-dump "y.dd._vptr->_final \\(&y.dd._data, (\\(integer\\(kind=8\\)\\) )?y.dd._vptr->_size, 1\\);" "original" } }
|
||||
|
||||
! { dg-final { cleanup-tree-dump "original" } }
|
||||
Loading…
Add table
Reference in a new issue