gcc/fortran/class.c | 20 +++-- gcc/fortran/resolve.c | 4 - gcc/fortran/trans-decl.c | 115 +++++++++++++++++++----- gcc/fortran/trans-stmt.c | 75 +++++++++++++++- gcc/fortran/trans.c | 98 +++++++++++++++++--- gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 | 2 +- gcc/testsuite/gfortran.dg/class_19.f03 | 2 +- gcc/testsuite/gfortran.dg/typebound_call_21.f03 | 2 +- 8 files changed, 266 insertions(+), 52 deletions(-) diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index d8e7b6d..524c371 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -965,6 +965,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, block->ext.actual->next = gfc_get_actual_arglist (); block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */ /* The part: TRANSFER (C_LOC (array), c_intptr_t). */ @@ -987,9 +988,9 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, /* TRANSFER. */ expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer", - gfc_current_locus, 2, expr, + gfc_current_locus, 3, expr, gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0)); + NULL, 0), NULL); expr2->ts.type = BT_INTEGER; expr2->ts.kind = gfc_index_integer_kind; @@ -1315,7 +1316,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, gfc_expr *shape_expr; tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - /* SIZE (array, dim=i+1, kind=default_kind). */ + /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */ shape_expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", gfc_current_locus, 3, @@ -1323,7 +1324,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, gfc_get_int_expr (gfc_default_integer_kind, NULL, i+1), gfc_get_int_expr (gfc_default_integer_kind, - NULL, 0)); + NULL, + gfc_index_integer_kind)); + shape_expr->ts.kind = gfc_index_integer_kind; tmp_array->as->upper[i] = shape_expr; } gfc_set_sym_referenced (tmp_array); @@ -1799,7 +1802,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_lval_expr_from_sym (array), gfc_lval_expr_from_sym (idx), gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0)); + NULL, + gfc_index_integer_kind)); + block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind; block->expr2->ts = idx->ts; /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */ @@ -2373,9 +2378,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) components and the calls to finalization subroutines. Note: The actual wrapper function can only be generated at resolution time. */ - /* FIXME: Enable ABI-breaking "_final" generation. */ - if (0) - { + if (gfc_add_component (vtype, "_final", &c) == FAILURE) goto cleanup; c->attr.proc_pointer = 1; @@ -2383,7 +2386,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; generate_finalization_wrapper (derived, ns, tname, c); - } /* Add procedure pointers for type-bound procedures. */ if (!derived->attr.unlimited_polymorphic) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a29fef9..4a1f530 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11787,10 +11787,6 @@ error: " defined at %L, suggest also scalar one", derived->name, &derived->declared_at); - /* TODO: Remove this error when finalization is finished. */ - gfc_error ("Finalization at %L is not yet implemented", - &derived->declared_at); - gfc_find_derived_vtab (derived); return result; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 337d747..eb90707 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1428,7 +1428,12 @@ gfc_get_symbol_decl (gfc_symbol * sym) && !sym->attr.data && !sym->attr.allocatable && (sym->value && !sym->ns->proc_name->attr.is_main_program) - && !(sym->attr.use_assoc && !intrinsic_array_parameter))) + && !(sym->attr.use_assoc && !intrinsic_array_parameter)) + /* Finalization. */ + || (sym->ts.type == BT_DERIVED && gfc_is_finalizable (sym->ts.u.derived, NULL) + && !sym->attr.pointer && !sym->attr.allocatable && !sym->attr.dummy + && !sym->attr.result && sym->attr.save == SAVE_NONE + && !sym->ns->proc_name->attr.is_main_program)) gfc_defer_symbol_init (sym); gfc_finish_var_decl (decl, sym); @@ -3468,7 +3473,30 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) && !f->sym->attr.pointer && f->sym->ts.type == BT_DERIVED) { - if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + gfc_expr *final_expr = NULL; + gfc_is_finalizable (f->sym->ts.u.derived, &final_expr); + + if (final_expr) + { + f->sym->attr.referenced = 1; + tmp = gfc_build_final_call (f->sym->ts, final_expr, + gfc_lval_expr_from_sym (f->sym), false, NULL); + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&init, tmp); + + if (f->sym->value) + gfc_init_default_dt (f->sym, &init, false); + } + else if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) { tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, f->sym->backend_decl, @@ -3490,25 +3518,65 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (f->sym && f->sym->attr.intent == INTENT_OUT && f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp) + && !CLASS_DATA (f->sym)->attr.class_pointer) { - tmp = gfc_class_data_get (f->sym->backend_decl); - if (CLASS_DATA (f->sym)->as == NULL) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived, - tmp, - CLASS_DATA (f->sym)->as ? - CLASS_DATA (f->sym)->as->rank : 0); - - if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) + gfc_expr *final_expr = NULL; + gfc_expr *vptr_size; + bool has_finalizer; + + has_finalizer = gfc_is_finalizable (f->sym->ts.u.derived, NULL); + /* Make sure the vtab is available. */ + if (!UNLIMITED_POLY (f->sym)) + gfc_find_derived_vtab (f->sym->ts.u.derived); + final_expr = gfc_lval_expr_from_sym (f->sym); + vptr_size = gfc_lval_expr_from_sym (f->sym); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + gfc_add_vptr_component (vptr_size); + gfc_add_component_ref (vptr_size, "_size"); + + f->sym->attr.referenced = 1; + tmp = gfc_build_final_call (f->sym->ts, final_expr, + gfc_lval_expr_from_sym (f->sym), false, + vptr_size); + + if (!has_finalizer) { - present = gfc_conv_expr_present (f->sym); + tree cond; +/* FIXME: For OPTIONAL, the condition is completely missing, see: PR fortran/54618 */ +/* cond = gfc_class_data_get (f->sym->backend_decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cond))) + cond = gfc_conv_descriptor_data_get (cond); + else if (!POINTER_TYPE_P (TREE_TYPE (cond))) + cond = gfc_build_addr_expr (NULL_TREE, cond); */ + + cond = gfc_vtable_final_get (f->sym->backend_decl); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond, build_int_cst (TREE_TYPE (cond), 0)); + + /* For CLASS(*) not only sym->_vtab->_final can be NULL but already + sym->_vtab itself. */ + if (UNLIMITED_POLY (f->sym)) + { + tree cond2; + cond2 = gfc_class_vptr_get (f->sym->backend_decl); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2, build_int_cst (TREE_TYPE (cond2), 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond2, cond); + } + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + } + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, - build_empty_stmt (input_location)); + cond, tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&init, tmp); } @@ -3518,12 +3586,13 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Generate function entry and exit code, and add it to the function body. This includes: - Allocation and initialization of array variables. - Allocation of character string variables. - Initialization and possibly repacking of dummy arrays. - Initialization of ASSIGN statement auxiliary variable. - Initialization of ASSOCIATE names. - Automatic deallocation. */ + - Allocation and initialization of array variables. + - Allocation of character string variables. + - Initialization and possibly repacking of dummy arrays. + - Initialization of ASSIGN statement auxiliary variable. + - Initialization of ASSOCIATE names. + - Automatic deallocation. + - Finalization. */ void gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 430b10e..382a254 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5243,6 +5243,7 @@ gfc_trans_allocate (gfc_code * code) gfc_add_component_ref (ppc, "_copy"); ppc_code = gfc_get_code (); + /* FIXME: Probably, the interface is not avilable, cf. _final ...*/ ppc_code->resolved_sym = ppc->symtree->n.sym; /* Although '_copy' is set to be elemental in class.c, it is not staying that way. Find out why, sometime.... */ @@ -5426,13 +5427,85 @@ gfc_trans_deallocate (gfc_code *code) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); +/* FIXME: HOW is var == NULL handled? And how are coarrays error stats handled? */ se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + + if (al->expr->ts.type == BT_CLASS) + { + gfc_is_finalizable (al->expr->ts.u.derived, NULL); + + final_expr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (al->expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + else if (al->expr->ts.type == BT_DERIVED) + gfc_is_finalizable (al->expr->ts.u.derived, &final_expr); + + if (final_expr) + { + tree cond; + + tmp = gfc_conv_descriptor_data_get (se.expr); + STRIP_NOPS (se.expr); + + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tmp, + null_pointer_node); + + if (al->expr->ts.type == BT_CLASS && !has_finalizer) + { + tree cond2; + gfc_se se2; + + /* For CLASS(*) not only sym->_vtab->_final can be NULL + but already sym->_vtab itself. */ + if (UNLIMITED_POLY (al->expr)) + { + cond2 = gfc_class_vptr_get (se.expr); + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + cond2, + build_int_cst (TREE_TYPE (cond2), + 0)); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + } + + gfc_init_se (&se2, NULL); + se2.want_pointer = 1; + gfc_conv_expr (&se2, final_expr); + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, se2.expr, + build_int_cst (TREE_TYPE (se2.expr), + 0)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, cond2); + } + + tmp = gfc_build_final_call (al->expr->ts, final_expr, + gfc_copy_expr (expr), false, + elem_size); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (!final_expr && expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) { gfc_ref *ref; gfc_ref *last = NULL; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index d7bdf26..7413f73 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1052,8 +1052,12 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, gfc_init_se (&se, NULL); se.want_pointer = 1; - if (var->rank || gfc_expr_attr (var).dimension) + if (var->rank || gfc_expr_attr (var).dimension + || (gfc_expr_attr (var).codimension + && 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; @@ -1087,13 +1091,17 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, size = se.expr; array_expr = gfc_copy_expr (var); - gfc_add_data_component (array_expr); gfc_init_se (&se, NULL); se.want_pointer = 1; - if (array_expr->rank || gfc_expr_attr (array_expr).dimension) + if (array_expr->rank || gfc_expr_attr (array_expr).dimension + || (gfc_expr_attr (array_expr).codimension + && 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, var); + gfc_conv_expr_descriptor (&se, array_expr); array = se.expr; if (! POINTER_TYPE_P (TREE_TYPE (array))) array = gfc_build_addr_expr (NULL, array); @@ -1103,6 +1111,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, symbol_attribute attr; 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; @@ -1186,21 +1195,86 @@ 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) +{ + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + bool has_finalizer = false; + +/* FIXME: !expr && ts.type == BT_CLASS shouldn't happen. + Cf. trans-array.c's structure_alloc_comps for a case where it does occur. */ + if (expr && ts.type == BT_CLASS) { - tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + has_finalizer = gfc_is_finalizable (ts.u.derived, NULL); + + 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"); + } + else if (expr && ts.type == BT_DERIVED) + gfc_is_finalizable (ts.u.derived, &final_expr); + + if (final_expr) + { + gcc_assert (expr); + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + tmp = gfc_build_final_call (ts, final_expr, + gfc_copy_expr (expr), false, + elem_size); + + if (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 (&non_null, tmp); } - else if (ts.type == BT_CLASS - && ts.u.derived->components->ts.u.derived->attr.alloc_comp) + + if (!final_expr && 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->components->ts.u.derived, - tmp, 0); + tmp = gfc_deallocate_alloc_comp (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, fold_convert (pvoid_type_node, pointer)); diff --git a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 index e607b6a..d261973 100644 --- a/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 +++ b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 @@ -25,5 +25,5 @@ contains end program -! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03 index 63b8e06..6dcd99c 100644 --- a/gcc/testsuite/gfortran.dg/class_19.f03 +++ b/gcc/testsuite/gfortran.dg/class_19.f03 @@ -39,5 +39,5 @@ program main end program main -! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 index e31bd6d..810ebfc 100644 --- a/gcc/testsuite/gfortran.dg/typebound_call_21.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 @@ -33,5 +33,5 @@ end module m print *,x%testfun() end -! { dg-final { scan-tree-dump-times "_vptr->" 0 "original" } } +! { dg-final { scan-tree-dump-times "_vptr->test" 0 "original" } } ! { dg-final { cleanup-tree-dump "original" } }