b/gcc/fortran/class.c | 48 ++++---- b/gcc/fortran/intrinsic.c | 8 - b/gcc/fortran/resolve.c | 4 b/gcc/fortran/trans-decl.c | 121 +++++++++++++++++----- b/gcc/fortran/trans-expr.c | 65 +++++++++++ b/gcc/fortran/trans-stmt.c | 75 +++++++++++++ b/gcc/fortran/trans.c | 104 ++++++++++++++++-- b/gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 | 2 b/gcc/testsuite/gfortran.dg/class_19.f03 | 2 b/gcc/testsuite/gfortran.dg/finalize_4.f03 | 3 b/gcc/testsuite/gfortran.dg/finalize_5.f03 | 3 b/gcc/testsuite/gfortran.dg/finalize_6.f90 | 3 b/gcc/testsuite/gfortran.dg/finalize_7.f03 | 3 b/gcc/testsuite/gfortran.dg/typebound_call_21.f03 | 2 gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 | 101 ++++++++++++++++++ 15 files changed, 457 insertions(+), 87 deletions(-) diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index d8e7b6d..564b4c7 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,8 @@ 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 +1806,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 +1969,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 +2382,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 +2390,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 2a51d10..64df296 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..984808ef 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) @@ -3805,7 +3879,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 06afc4f..84544db 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4085,10 +4085,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, @@ -4116,6 +4114,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE + && !e->ref && e->symtree->n.sym->attr.optional) { tmp = fold_build3_loc (input_location, COND_EXPR, @@ -4180,6 +4179,64 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, { /* Pass a class array. */ gfc_conv_expr_descriptor (&parmse, e); + + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is + allocated on entry, it must be deallocated. */ + if (fsym->attr.intent == INTENT_OUT + && CLASS_DATA (fsym)->attr.allocatable) + { + stmtblock_t block; + tree ptr; + + gfc_init_block (&block); + ptr = parmse.expr; + ptr = gfc_class_data_get (ptr); + + tmp = gfc_deallocate_with_status (ptr, NULL_TREE, + NULL_TREE, NULL_TREE, + NULL_TREE, true, e, + false); + gfc_add_expr_to_block (&block, tmp); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, ptr, + null_pointer_node); + gfc_add_expr_to_block (&block, tmp); + + if (UNLIMITED_POLY (fsym)) + gfc_add_modify (&block, ptr, + fold_convert (TREE_TYPE (ptr), + null_pointer_node)); + else + { + gfc_symbol *vtab; + vtab = gfc_find_derived_vtab (fsym->ts.u.derived); + tmp = gfc_get_symbol_decl (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + ptr = gfc_class_vptr_get (parmse.expr); + gfc_add_modify (&block, ptr, + fold_convert (TREE_TYPE (ptr), tmp)); + } + gfc_add_expr_to_block (&block, tmp); + + if (fsym->attr.optional + && e->expr_type == EXPR_VARIABLE + && (!e->ref + || (e->ref->type == REF_ARRAY + && !e->ref->u.ar.type != AR_FULL)) + && e->symtree->n.sym->attr.optional) + { + tmp = fold_build3_loc (input_location, COND_EXPR, + void_type_node, + gfc_conv_expr_present (e->symtree->n.sym), + gfc_finish_block (&block), + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + + gfc_add_expr_to_block (&se->pre, tmp); +} + /* The conversion does not repackage the reference to a class array - _data descriptor. */ gfc_conv_class_to_class (&parmse, e, fsym->ts, false, 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..0644d6f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1031,6 +1031,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, 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); @@ -1041,6 +1042,8 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, 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; @@ -1052,8 +1055,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 || 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; @@ -1062,7 +1069,6 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, } else { - symbol_attribute attr; gfc_clear_attr (&attr); gfc_conv_expr (&se, var); gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); @@ -1087,22 +1093,25 @@ 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 || 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, 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); } else { - 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/finalize_4.f03 b/gcc/testsuite/gfortran.dg/finalize_4.f03 index 11e094f..b4c08f2 100644 --- a/gcc/testsuite/gfortran.dg/finalize_4.f03 +++ b/gcc/testsuite/gfortran.dg/finalize_4.f03 @@ -48,6 +48,3 @@ PROGRAM finalizer DEALLOCATE(mat) END PROGRAM finalizer - -! TODO: Remove this once finalization is implemented. -! { dg-excess-errors "not yet implemented" } diff --git a/gcc/testsuite/gfortran.dg/finalize_5.f03 b/gcc/testsuite/gfortran.dg/finalize_5.f03 index b9ec376..fb81531 100644 --- a/gcc/testsuite/gfortran.dg/finalize_5.f03 +++ b/gcc/testsuite/gfortran.dg/finalize_5.f03 @@ -107,6 +107,3 @@ PROGRAM finalizer IMPLICIT NONE ! Nothing here, errors above END PROGRAM finalizer - -! TODO: Remove this once finalization is implemented. -! { dg-excess-errors "not yet implemented" } diff --git a/gcc/testsuite/gfortran.dg/finalize_6.f90 b/gcc/testsuite/gfortran.dg/finalize_6.f90 index 82d662f..d888a4b 100644 --- a/gcc/testsuite/gfortran.dg/finalize_6.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_6.f90 @@ -28,6 +28,3 @@ PROGRAM finalizer IMPLICIT NONE ! Do nothing END PROGRAM finalizer - -! TODO: Remove this once finalization is implemented. -! { dg-excess-errors "not yet implemented" } diff --git a/gcc/testsuite/gfortran.dg/finalize_7.f03 b/gcc/testsuite/gfortran.dg/finalize_7.f03 index 6ca4f55..5807ed5 100644 --- a/gcc/testsuite/gfortran.dg/finalize_7.f03 +++ b/gcc/testsuite/gfortran.dg/finalize_7.f03 @@ -52,6 +52,3 @@ PROGRAM finalizer IMPLICIT NONE ! Nothing here END PROGRAM finalizer - -! TODO: Remove this once finalization is implemented. -! { dg-excess-errors "not yet implemented" } 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-27 09:07:08.581020430 +0100 +++ gcc/gcc/testsuite/gfortran.dg/finalize_10.f90 2013-03-27 16:58:20.559768585 +0100 @@ -0,0 +1,101 @@ +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 (global_count1 == -1) call abort () + 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 (global_count1 == -1) call abort () + 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(:) + + 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 ()! FIXME: YAA/YAC are not finalized + + block + type(t), allocatable :: za + class(t), allocatable :: zc + type(t), allocatable :: zaa(:) + class(t), allocatable :: zca(:) + + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + call foo(za, zc, zaa, zca) + if (global_count1 /= 2) call abort () + !if (global_count2 /= 2) call abort ()! FIXME: YAA/YAC are not finalized + + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + print *, 'BLOCK DONE' + end block + + if (global_count1 /= 2) call abort () + !if (global_count2 /= 2) call abort ()! FIXME: YAA is not finalized + + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = -1 + global_count2 = -1 + ya%i = 42 + yc%i = 42 + yaa%i = [1,2,3,4,5] + 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