b/gcc/fortran/class.c | 47 ++++---- b/gcc/fortran/intrinsic.c | 8 - b/gcc/fortran/resolve.c | 4 b/gcc/fortran/trans-decl.c | 118 +++++++++++++++++----- b/gcc/fortran/trans-stmt.c | 75 +++++++++++++ b/gcc/fortran/trans.c | 98 ++++++++++++++++-- b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 | 2 b/gcc/testsuite/gfortran.dg/class_19.f03 | 2 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 | 2 gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 | 68 ++++++++++++ 10 files changed, 357 insertions(+), 67 deletions(-) diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index d8e7b6d..3b4eb404 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -956,8 +956,10 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, block->resolved_sym = block->symtree->n.sym; block->resolved_sym->attr.flavor = FL_PROCEDURE; block->resolved_sym->attr.intrinsic = 1; + block->resolved_sym->attr.subroutine = 1; block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING; block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER; + block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER); gfc_commit_symbol (block->resolved_sym); /* C_F_POINTER's first argument: TRANSFER ( , c_intptr_t). */ @@ -965,6 +967,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). */ @@ -976,7 +979,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC; expr->symtree->n.sym->attr.intrinsic = 1; expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING; - expr->value.function.esym = expr->symtree->n.sym; + expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC); expr->value.function.actual = gfc_get_actual_arglist (); expr->value.function.actual->expr = gfc_lval_expr_from_sym (array); @@ -987,9 +990,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; @@ -1200,9 +1203,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, size_expr->value.op.op1 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE, "storage_size", gfc_current_locus, 2, - gfc_lval_expr_from_sym (array)); + gfc_lval_expr_from_sym (array), gfc_get_int_expr (gfc_index_integer_kind, - NULL, 0); + NULL, 0)); /* NUMERIC_STORAGE_SIZE. */ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, @@ -1215,7 +1218,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, || is_contiguous) || 0 == size_expr. */ block->expr1 = gfc_get_expr (); - block->expr1->expr_type = EXPR_FUNCTION; block->expr1->ts.type = BT_LOGICAL; block->expr1->ts.kind = gfc_default_logical_kind; block->expr1->expr_type = EXPR_OP; @@ -1234,8 +1236,9 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, = gfc_lval_expr_from_sym (byte_stride); expr->value.op.op2 = size_expr; - /* If strides aren't allowd (not assumed shape or CONTIGUOUS), + /* If strides aren't allowed (not assumed shape or CONTIGUOUS), add is_contiguous check. */ + if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE || fini->proc_tree->n.sym->formal->sym->attr.contiguous) { @@ -1315,7 +1318,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 +1326,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); @@ -1346,7 +1351,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, /* Offset calculation for the new array: idx * size of type (in bytes). */ offset2 = gfc_get_expr (); - offset2 = block->ext.actual->expr; offset2->expr_type = EXPR_OP; offset2->value.op.op = INTRINSIC_TIMES; offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); @@ -1365,13 +1369,15 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, sub_ns); block2 = block2->next; block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); + block2 = block2->next; /* ptr2 = ptr. */ block2->next = XCNEW (gfc_code); - block2->next->op = EXEC_ASSIGN; - block2->next->loc = gfc_current_locus; - block2->next->expr1 = gfc_lval_expr_from_sym (ptr2); - block2->next->expr2 = gfc_lval_expr_from_sym (ptr); + block2 = block2->next; + block2->op = EXEC_ASSIGN; + block2->loc = gfc_current_locus; + block2->expr1 = gfc_lval_expr_from_sym (ptr2); + block2->expr2 = gfc_lval_expr_from_sym (ptr); /* Call now the user's final subroutine. */ block->next = XCNEW (gfc_code); @@ -1414,7 +1420,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, gfc_lval_expr_from_sym (offset), sub_ns); block2 = block2->next; - block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); + block2->next = finalization_scalarizer (tmp_array, ptr2, gfc_copy_expr (offset2), sub_ns); block2 = block2->next; /* ptr = ptr2. */ @@ -1799,7 +1805,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. */ @@ -1960,7 +1968,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->ext.block.case_list->low = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); block->ext.block.case_list->high - = block->ext.block.case_list->low; + = gfc_copy_expr (block->ext.block.case_list->low); /* CALL fini_rank (array) - possibly with packing. */ if (fini->proc_tree->n.sym->formal->sym->attr.dimension) @@ -2373,9 +2381,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 +2389,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/intrinsic.c b/gcc/fortran/intrinsic.c index 358c33e..e451c36 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -813,7 +813,9 @@ find_sym (gfc_intrinsic_sym *start, int n, const char *name) gfc_isym_id gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id) { - if (from_intmod == INTMOD_ISO_C_BINDING) + if (from_intmod == INTMOD_NONE) + return (gfc_isym_id) intmod_sym_id; + else if (from_intmod == INTMOD_ISO_C_BINDING) return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value; else if (from_intmod == INTMOD_ISO_FORTRAN_ENV) switch (intmod_sym_id) @@ -829,9 +831,7 @@ gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id) gcc_unreachable (); } else - { - gcc_unreachable (); - } + gcc_unreachable (); return (gfc_isym_id) 0; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 835b57f..9959a07 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -11224,10 +11224,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 0e853ba..8ab1ae7 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1427,7 +1427,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); @@ -3464,7 +3469,32 @@ 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); + + /* Allocatables are deallocated in the caller - hence, + they have to be finalized there. */ + if (final_expr && !f->sym->attr.allocatable) + { + 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, @@ -3484,27 +3514,70 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) else if (f->sym->value) gfc_init_default_dt (f->sym, &init, true); } + /* Allocatables are deallocated in the caller - hence, + they have to be finalized there. */ 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.allocatable) { - 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); } @@ -3514,12 +3587,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" } } --- /dev/null 2013-03-25 08:38:54.460013510 +0100 +++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-03-25 22:14:07.502657531 +0100 @@ -0,0 +1,68 @@ +module m + implicit none + type t + integer :: i + contains + final :: fini, fini2 + end type t + integer :: global_count1, global_count2 +contains + subroutine fini(x) + type(t) :: x + print *, x%i + if (x%i /= 42) call abort() + x%i = 33 + global_count1 = global_count1 + 1 + end subroutine fini + subroutine fini2(x) + type(t) :: x(:) + print *, x%i + if (size(x) /= 5) call abort() + if (any (x%i /= [1,2,3,4,5])) call abort() + x%i = 33 + global_count2 = global_count2 + 10 + end subroutine fini2 +end module m + +program pp + use m + implicit none + type(t), allocatable :: ya + class(t), allocatable :: yc + type(t), allocatable :: yaa(:) + class(t), allocatable :: yca(:) +! save :: ya, yc, yaa, yca ! FIXME: Without, finalization happens! + + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = 0 + global_count2 = 0 + ya%i = 42 + yc%i = 42 + yaa%i = [1,2,3,4,5] + yca%i = [1,2,3,4,5] + + call foo(ya, yc, yaa, yca) + !if (global_count1 /= 2) call abort () + !if (global_count2 /= 2) call abort () + + allocate (ya, yc, yaa(5)) !, yca(5)) ! FIXME: Not deallocated + global_count1 = 0 + global_count2 = 0 + ya%i = 42 + yc%i = 42 + yaa%i = [1,2,3,4,5]! FIXME: YAA is not finalized + yca%i = [1,2,3,4,5] + + print *, 'DONE' +contains + subroutine foo(xa, xc, xaa, xca) + type(t), allocatable, intent(out) :: xa + class(t), allocatable, intent(out) :: xc + type(t), allocatable, intent(out) :: xaa(:) + class(t), allocatable, intent(out) :: xca(:) + if (allocated (xa)) call abort () + if (allocated (xc)) call abort () + if (allocated (xaa)) call abort () + !if (allocated (xca)) call abort () ! FIXME: SEGFAULT + end subroutine foo +end program