diff options
author | Tobias Burnus <burnus@gcc.gnu.org> | 2013-06-04 12:20:32 +0200 |
---|---|---|
committer | Tobias Burnus <burnus@gcc.gnu.org> | 2013-06-04 12:20:32 +0200 |
commit | ef2925370ee74f7b0d0845affc35b0030848b5ae (patch) | |
tree | bc5eafdea238518ce5c6c9b8cd674dc39145b8b3 /gcc/fortran | |
parent | aadaf24ef0336560cb808406da288878a6120ca2 (diff) | |
download | gcc-ef2925370ee74f7b0d0845affc35b0030848b5ae.zip gcc-ef2925370ee74f7b0d0845affc35b0030848b5ae.tar.gz gcc-ef2925370ee74f7b0d0845affc35b0030848b5ae.tar.bz2 |
re PR fortran/37336 ([F03] Finish derived-type finalization)
2013-06-03 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* trans.h (gfc_build_final_call): Remove prototype.
(gfc_add_finalizer_call): Add prototype.
* trans-array.c (gfc_trans_dealloc_allocated): Support
* finalization.
(structure_alloc_comps): Update caller.
(gfc_trans_deferred_array): Call finalizer.
* trans-array.h (gfc_trans_dealloc_allocated): Update prototype.
* trans-decl.c (gfc_trans_deferred_vars): Don't
* deallocate/finalize
variables of the main program.
* trans-expr.c (gfc_conv_procedure_call): Support finalization.
* trans-openmp.c (gfc_omp_clause_dtor,
gfc_trans_omp_array_reduction): Update calls.
* trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation
of alloc components.
* trans.c (gfc_add_finalizer_call): New function.
(gfc_deallocate_with_status,
gfc_deallocate_scalar_with_status): Call it
(gfc_build_final_call): Fix handling of scalar coarrays,
move up in the file and make static.
2013-06-03 Tobias Burnus <burnus@net-b.de>
PR fortran/37336
* gfortran.dg/finalize_12.f90: New.
* gfortran.dg/alloc_comp_basics_1.f90: Add BLOCK for
end of scope finalization.
* gfortran.dg/alloc_comp_constructor_1.f90: Ditto.
* gfortran.dg/allocatable_scalar_9.f90: Ditto.
* gfortran.dg/auto_dealloc_2.f90: Ditto.
* gfortran.dg/class_19.f03: Ditto.
* gfortran.dg/coarray_lib_alloc_1.f90: Ditto.
* gfortran.dg/coarray_lib_alloc_2.f90: Ditto.
* gfortran.dg/extends_14.f03: Ditto.
* gfortran.dg/move_alloc_4.f90: Ditto.
* gfortran.dg/typebound_proc_27.f03: Ditto.
From-SVN: r199643
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 22 | ||||
-rw-r--r-- | gcc/fortran/trans-array.c | 25 | ||||
-rw-r--r-- | gcc/fortran/trans-array.h | 2 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 3 | ||||
-rw-r--r-- | gcc/fortran/trans-expr.c | 12 | ||||
-rw-r--r-- | gcc/fortran/trans-openmp.c | 5 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 3 | ||||
-rw-r--r-- | gcc/fortran/trans.c | 349 | ||||
-rw-r--r-- | gcc/fortran/trans.h | 3 |
9 files changed, 273 insertions, 151 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2043691..d8ff752 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2013-06-04 Tobias Burnus <burnus@net-b.de> + + PR fortran/37336 + * trans.h (gfc_build_final_call): Remove prototype. + (gfc_add_finalizer_call): Add prototype. + * trans-array.c (gfc_trans_dealloc_allocated): Support finalization. + (structure_alloc_comps): Update caller. + (gfc_trans_deferred_array): Call finalizer. + * trans-array.h (gfc_trans_dealloc_allocated): Update prototype. + * trans-decl.c (gfc_trans_deferred_vars): Don't deallocate/finalize + variables of the main program. + * trans-expr.c (gfc_conv_procedure_call): Support finalization. + * trans-openmp.c (gfc_omp_clause_dtor, + gfc_trans_omp_array_reduction): Update calls. + * trans-stmt.c (gfc_trans_deallocate): Avoid double deallocation + of alloc components. + * trans.c (gfc_add_finalizer_call): New function. + (gfc_deallocate_with_status, + gfc_deallocate_scalar_with_status): Call it + (gfc_build_final_call): Fix handling of scalar coarrays, + move up in the file and make static. + 2013-06-01 Janus Weil <janus@gcc.gnu.org> Mikael Morin <mikael@gcc.gnu.org> diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 8556278..89f26d7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7247,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Generate code to deallocate an array, if it is allocated. */ tree -gfc_trans_dealloc_allocated (tree descriptor, bool coarray) +gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr) { tree tmp; tree var; @@ -7263,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray) are already deallocated are ignored. */ tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, - NULL, coarray); + expr, coarray); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -7552,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension); + tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL); gfc_add_expr_to_block (&tmpblock, tmp); } else if (c->attr.allocatable) @@ -7584,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) tmp = gfc_trans_dealloc_allocated (comp, - CLASS_DATA (c)->attr.codimension); + CLASS_DATA (c)->attr.codimension, NULL); else { tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, @@ -8296,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) stmtblock_t cleanup; locus loc; int rank; - bool sym_has_alloc_comp; + bool sym_has_alloc_comp, has_finalizer; sym_has_alloc_comp = (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) @@ -8383,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) /* Allocatable arrays need to be freed when they go out of scope. The allocatable components of pointers must not be touched. */ - if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) - && !sym->attr.pointer && !sym->attr.save) + has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED + ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; + if ((!sym->attr.allocatable || !has_finalizer) + && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result) + && !sym->attr.pointer && !sym->attr.save + && !sym->ns->proc_name->attr.is_main_program) { int rank; rank = sym->as ? sym->as->rank : 0; @@ -8393,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) } if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) - && !sym->attr.save && !sym->attr.result) + && !sym->attr.save && !sym->attr.result + && !sym->ns->proc_name->attr.is_main_program) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl, - sym->attr.codimension); + sym->attr.codimension, + has_finalizer + ? gfc_lval_expr_from_sym (sym) : NULL); gfc_add_expr_to_block (&cleanup, tmp); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index d00e156..8d9e461 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -42,7 +42,7 @@ void gfc_trans_dummy_array_bias (gfc_symbol *, tree, gfc_wrapped_block *); /* Generate entry and exit code for g77 calling convention arrays. */ void gfc_trans_g77_array (gfc_symbol *, gfc_wrapped_block *); /* Generate code to deallocate an array, if it is allocated. */ -tree gfc_trans_dealloc_allocated (tree, bool); +tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 100ec18..b0e3ffc 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3872,7 +3872,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Deallocate when leaving the scope. Nullifying is not needed. */ - if (!sym->attr.result && !sym->attr.dummy) + if (!sym->attr.result && !sym->attr.dummy + && !sym->ns->proc_name->attr.is_main_program) { if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 07b0fa6..9d07345 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4274,10 +4274,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (e->ts.type == BT_CLASS) ptr = gfc_class_data_get (ptr); - tmp = gfc_deallocate_with_status (ptr, NULL_TREE, - NULL_TREE, NULL_TREE, - NULL_TREE, true, NULL, - false); + tmp = gfc_deallocate_scalar_with_status (ptr, NULL_TREE, + true, e, e->ts); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ptr, @@ -4409,8 +4407,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, else tmp = gfc_finish_block (&block); - gfc_add_expr_to_block (&se->pre, tmp); -} + gfc_add_expr_to_block (&se->pre, tmp); + } /* The conversion does not repackage the reference to a class array - _data descriptor. */ @@ -4511,7 +4509,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - tmp = gfc_trans_dealloc_allocated (tmp, false); + tmp = gfc_trans_dealloc_allocated (tmp, false, e); if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 882927e..2765561 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -325,7 +325,7 @@ gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl, false); + return gfc_trans_dealloc_allocated (decl, false, NULL); } @@ -707,7 +707,8 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_start_block (&block); gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false)); + gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false, + NULL)); stmt = gfc_finish_block (&block); } else diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7759b86..e2d0110 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5398,7 +5398,8 @@ gfc_trans_deallocate (gfc_code *code) if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp + && !gfc_is_finalizable (expr->ts.u.derived, NULL)) { gfc_ref *ref; gfc_ref *last = NULL; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 8211573..a1ea300 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -838,6 +838,223 @@ gfc_call_free (tree var) } +/* Build a call to a FINAL procedure, which finalizes "var". */ + +static tree +gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, + bool fini_coarray, gfc_expr *class_size) +{ + stmtblock_t block; + gfc_se se; + tree final_fndecl, array, size, tmp; + symbol_attribute attr; + + gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); + gcc_assert (var); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, final_wrapper); + final_fndecl = se.expr; + if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) + final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); + + if (ts.type == BT_DERIVED) + { + tree elem_size; + + gcc_assert (!class_size); + elem_size = gfc_typenode_for_spec (&ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + size = fold_convert (gfc_array_index_type, elem_size); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (var->rank) + { + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, var); + array = se.expr; + } + else + { + gfc_conv_expr (&se, var); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + gcc_assert (se.post.head == NULL_TREE); + } + } + else + { + gfc_expr *array_expr; + gcc_assert (class_size); + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, class_size); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + size = se.expr; + + array_expr = gfc_copy_expr (var); + gfc_init_se (&se, NULL); + se.want_pointer = 1; + if (array_expr->rank) + { + gfc_add_class_array_ref (array_expr); + se.descriptor_only = 1; + gfc_conv_expr_descriptor (&se, array_expr); + array = se.expr; + } + else + { + gfc_add_data_component (array_expr); + gfc_conv_expr (&se, array_expr); + gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + array = se.expr; + if (TREE_CODE (array) == ADDR_EXPR + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) + tmp = TREE_OPERAND (array, 0); + + if (!gfc_is_coarray (array_expr)) + { + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + gfc_init_se (&se, NULL); + array = gfc_conv_scalar_to_descriptor (&se, array, attr); + } + gcc_assert (se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + if (!POINTER_TYPE_P (TREE_TYPE (array))) + array = gfc_build_addr_expr (NULL, array); + + gfc_start_block (&block); + gfc_add_block_to_block (&block, &se.pre); + tmp = build_call_expr_loc (input_location, + final_fndecl, 3, array, + size, fini_coarray ? boolean_true_node + : boolean_false_node); + gfc_add_block_to_block (&block, &se.post); + gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); +} + + +/* Add a call to the finalizer, using the passed *expr. Returns + true when a finalizer call has been inserted. */ + +bool +gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) +{ + tree tmp; + gfc_ref *ref; + gfc_expr *expr; + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) + return false; + + if (expr2->ts.type == BT_DERIVED) + { + gfc_is_finalizable (expr2->ts.u.derived, &final_expr); + if (!final_expr) + return false; + } + + /* If we have a class array, we need go back to the class + container. */ + expr = gfc_copy_expr (expr2); + + if (expr->ref && expr->ref->next && !expr->ref->next->next + && expr->ref->next->type == REF_ARRAY + && expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (expr->ref); + expr->ref = NULL; + } + else + for (ref = expr->ref; ref; ref = ref->next) + if (ref->next && ref->next->next && !ref->next->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0) + { + gfc_free_ref_list (ref->next); + ref->next = NULL; + } + + if (expr->ts.type == BT_CLASS) + { + has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); + + if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) + expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; + + final_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (expr->ts, final_expr, expr, + false, elem_size); + + if (expr->ts.type == BT_CLASS && !has_finalizer) + { + tree cond; + gfc_se se; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, final_expr); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (expr)) + { + tree cond2; + gfc_expr *vptr_expr; + + vptr_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (vptr_expr); + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, vptr_expr); + gfc_free_expr (vptr_expr); + + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond2, cond); + } + + 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; +} + /* User-deallocate; we emit the code directly from the front-end, and the logic is the same as the previous library function: @@ -930,6 +1147,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); + gfc_add_finalizer_call (&non_null, expr); if (!coarray || gfc_option.coarray != GFC_FCOARRAY_LIB) { tmp = build_call_expr_loc (input_location, @@ -1022,125 +1240,6 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, } -/* Build a call to a FINAL procedure, which finalizes "var". */ - -tree -gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, - bool fini_coarray, gfc_expr *class_size) -{ - stmtblock_t block; - gfc_se se; - tree final_fndecl, array, size, tmp; - symbol_attribute attr; - - gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); - gcc_assert (var); - - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, final_wrapper); - final_fndecl = se.expr; - if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) - final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); - - attr = gfc_expr_attr (var); - - if (ts.type == BT_DERIVED) - { - tree elem_size; - - gcc_assert (!class_size); - elem_size = gfc_typenode_for_spec (&ts); - elem_size = TYPE_SIZE_UNIT (elem_size); - size = fold_convert (gfc_array_index_type, elem_size); - - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (var->rank || attr.dimension - || (attr.codimension && attr.allocatable - && gfc_option.coarray == GFC_FCOARRAY_LIB)) - { - if (var->rank == 0) - se.want_coarray = 1; - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, var); - array = se.expr; - if (!POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - } - else - { - gfc_clear_attr (&attr); - gfc_conv_expr (&se, var); - gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); - array = se.expr; - if (TREE_CODE (array) == ADDR_EXPR - && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) - tmp = TREE_OPERAND (array, 0); - - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - array = gfc_build_addr_expr (NULL, array); - gcc_assert (se.post.head == NULL_TREE); - } - } - else - { - gfc_expr *array_expr; - gcc_assert (class_size); - gfc_init_se (&se, NULL); - gfc_conv_expr (&se, class_size); - gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); - size = se.expr; - - array_expr = gfc_copy_expr (var); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (array_expr->rank || attr.dimension - || (attr.codimension && attr.allocatable - && gfc_option.coarray == GFC_FCOARRAY_LIB)) - { - gfc_add_class_array_ref (array_expr); - if (array_expr->rank == 0) - se.want_coarray = 1; - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, array_expr); - array = se.expr; - if (! POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - } - else - { - gfc_clear_attr (&attr); - gfc_add_data_component (array_expr); - gfc_conv_expr (&se, array_expr); - gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); - array = se.expr; - if (TREE_CODE (array) == ADDR_EXPR - && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (array, 0)))) - tmp = TREE_OPERAND (array, 0); - - /* attr: Argument is neither a pointer/allocatable, - i.e. no copy back needed */ - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - array = gfc_build_addr_expr (NULL, array); - gcc_assert (se.post.head == NULL_TREE); - } - gfc_free_expr (array_expr); - } - - gfc_start_block (&block); - gfc_add_block_to_block (&block, &se.pre); - tmp = build_call_expr_loc (input_location, - final_fndecl, 3, array, - size, fini_coarray ? boolean_true_node - : boolean_false_node); - gfc_add_block_to_block (&block, &se.post); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); -} - - /* Generate code for deallocation of allocatable scalars (variables or components). Before the object itself is freed, any allocatable subcomponents are being deallocated. */ @@ -1151,6 +1250,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, { stmtblock_t null, non_null; tree cond, tmp, error; + bool finalizable; cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1195,20 +1295,13 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, gfc_start_block (&non_null); /* Free allocatable components. */ - if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) + finalizable = gfc_add_finalizer_call (&non_null, expr); + if (!finalizable && 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, builtin_decl_explicit (BUILT_IN_FREE), 1, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 0c0fe5d..06cb63d 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -352,8 +352,7 @@ tree gfc_vtable_final_get (tree); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree); -tree gfc_build_final_call (gfc_typespec, gfc_expr *, gfc_expr *, bool, - gfc_expr *); +bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *); 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, |