diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 16ea97b..cde5739 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -6157,6 +6157,8 @@ gfc_use_module (gfc_use_list *module) "intrinsic module at %C") != FAILURE) { use_iso_fortran_env_module (); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6167,6 +6169,8 @@ gfc_use_module (gfc_use_list *module) "ISO_C_BINDING module at %C") != FAILURE) { import_iso_c_binding_module(); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6359,8 +6363,6 @@ gfc_use_modules (void) next = module_list->next; rename_list_remove_duplicate (module_list->rename); gfc_use_module (module_list); - if (module_list->intrinsic) - free_rename (module_list->rename); free (module_list); } gfc_rename_list = NULL; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 69646de..96ca104 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -428,7 +428,11 @@ resolve_formal_arglist (gfc_symbol *proc) if (!gfc_pure(sym)) proc->attr.implicit_pure = 0; } - else if (!sym->attr.pointer) + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.class_pointer)) + proc->attr.implicit_pure = 0; + else { if (proc->attr.function && sym->attr.intent != INTENT_IN && !sym->value) @@ -11694,10 +11698,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-array.c b/gcc/fortran/trans-array.c index 24adfde..0689892 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7589,7 +7589,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, CLASS_DATA (c)->attr.codimension); else { - tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, + tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, CLASS_DATA (c)->ts); gfc_add_expr_to_block (&tmpblock, tmp); called_dealloc_with_status = true; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3bee178..5fe4690 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3430,7 +3430,41 @@ 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_symbol *vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gfc_expr *final_expr = NULL; + + if (vtab) + { + gfc_component *final; + + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + final_expr = final->initializer; + } + + 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, @@ -3452,25 +3486,58 @@ 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) - { - present = gfc_conv_expr_present (f->sym); + gfc_expr *final_expr = NULL; + gfc_expr *vptr_size; + gfc_symbol *vtab; + gfc_component *final; + + /* Make sure the vtab is available. */ + 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); + + /* We don't need add a run-time check when we know that a + finalization wrapper exists. */ + vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gcc_assert (vtab); + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (!final->initializer || final->initializer->expr_type == EXPR_NULL) + { + 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)); + + 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); } @@ -3780,9 +3847,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) NULL_TREE, true, NULL, true); else - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, - true, NULL, - sym->ts); + tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE, + true, + gfc_lval_expr_from_sym (sym), + sym->ts); } if (sym->ts.type == BT_CLASS) { diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 79dc27d..24056b1 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5190,6 +5190,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.... */ @@ -5349,13 +5350,81 @@ 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; + + if (al->expr->ts.type == BT_CLASS) + { + 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_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components; + final = final->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer + && final->initializer->expr_type != EXPR_NULL) + final_expr = final->initializer; + } + } + + 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) + { + tree cond2; + gfc_se se2; + + 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; @@ -5380,7 +5449,7 @@ gfc_trans_deallocate (gfc_code *code) else { tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, - expr, expr->ts); + al->expr, al->expr->ts); gfc_add_expr_to_block (&se.pre, tmp); /* Set to zero after deallocation. */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 35a39c5..caf9eb6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2654,7 +2654,7 @@ create_fn_spec (gfc_symbol *sym, tree fntype) { gfc_symbol *result = sym->result ? sym->result : sym; - if (result->attr.pointer || sym->attr.proc_pointer) + if (result->attr.pointer || result->attr.proc_pointer) spec[spec_len++] = '.'; else spec[spec_len++] = 'w'; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6365213..6eebb5e 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1023,6 +1023,56 @@ 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) +{ + gfc_code *code; + gfc_expr *size; + tree tmp; + + gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); + gcc_assert (var); + + code = gfc_get_code (); + + if (ts.type == BT_DERIVED) + { + tree elem_size; + + code->resolved_sym = final_wrapper->symtree->n.sym; + gcc_assert (!class_size); + elem_size = gfc_typenode_for_spec (&ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + gcc_assert (TREE_INT_CST_HIGH (elem_size) == 0); + size = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (elem_size)); + } + else + { + gcc_assert (class_size); + size = class_size; + code->resolved_sym = gfc_get_proc_ptr_comp (final_wrapper)->ts.interface; + } + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = var; + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + fini_coarray); + code->expr1 = gfc_copy_expr (final_wrapper); + code->op = EXEC_CALL; + + tmp = gfc_trans_call (code, true, NULL, NULL, false); + gfc_free_statements (code); + return tmp; +} + + /* Generate code for deallocation of allocatable scalars (variables or components). Before the object itself is freed, any allocatable subcomponents are being deallocated. */ @@ -1077,21 +1127,96 @@ 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; + gfc_code *code; + +/* 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); + 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_symbol *vtab = gfc_find_derived_vtab (ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + { + tree size; + + final_expr = final->initializer; + + size = gfc_typenode_for_spec (&ts); + size = TYPE_SIZE_UNIT (size); + gcc_assert (TREE_INT_CST_HIGH (size) == 0); + elem_size = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (size)); + } + } + } + + if (final_expr) + { + gcc_assert (expr); + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + code = gfc_get_code (); + if (ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: IS this properly reachable and makes sense? and initialized above? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = elem_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + if (ts.type == BT_CLASS) + { + 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)); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + + gfc_free_statements (code); 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/fortran/trans.h b/gcc/fortran/trans.h index 1779575..8e9dfd6 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -352,6 +352,8 @@ 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 *); 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,