diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 28 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 96 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 2 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/finalize_18.f90 | 47 |
6 files changed, 179 insertions, 6 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 35c884c..f103a6d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 39bf0dd..513c073 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index f17eaca..53a0669 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -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. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 06cb63d..424ce7a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2e609ed..beececc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/finalize_18.f90 b/gcc/testsuite/gfortran.dg/finalize_18.f90 new file mode 100644 index 0000000..f018ae2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_18.f90 @@ -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" } } |