fortran/check.c | 2 fortran/class.c | 150 ++++++++++++++++++++++++----------- fortran/expr.c | 13 ++- fortran/gfortran.h | 1 fortran/interface.c | 2 fortran/iresolve.c | 4 fortran/parse.c | 3 fortran/resolve.c | 27 +++--- fortran/trans-array.c | 2 fortran/trans-decl.c | 140 +++++++++++++++++++++++++------- fortran/trans-expr.c | 15 ++- fortran/trans-intrinsic.c | 6 - fortran/trans-stmt.c | 86 ++++++++++++++++++-- fortran/trans-types.c | 2 fortran/trans.c | 72 ++++++++++++++-- fortran/trans.h | 2 testsuite/gfortran.dg/finalize_4.f03 | 5 - testsuite/gfortran.dg/finalize_5.f03 | 3 testsuite/gfortran.dg/finalize_6.f90 | 3 testsuite/gfortran.dg/finalize_7.f03 | 3 20 files changed, 406 insertions(+), 135 deletions(-) diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 58c5856..147edf9 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2801,7 +2801,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) /* CLASS arguments: Make sure the vtab of from is present. */ if (to->ts.type == BT_CLASS) - gfc_find_derived_vtab (from->ts.u.derived); + gfc_get_derived_vtab (from->ts.u.derived); return SUCCESS; } diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 2e347cb..cd43b68 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -416,7 +416,7 @@ gfc_class_null_initializer (gfc_typespec *ts) { gfc_constructor *ctor = gfc_constructor_get(); if (strcmp (comp->name, "_vptr") == 0) - ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); + ctor->expr = gfc_lval_expr_from_sym (gfc_get_derived_vtab (ts->u.derived)); else ctor->expr = gfc_get_null_expr (NULL); gfc_constructor_append (&init->value.constructor, ctor); @@ -454,7 +454,7 @@ get_unique_hashed_string (char *string, gfc_symbol *derived) char tmp[2*GFC_MAX_SYMBOL_LEN+2]; get_unique_type_string (&tmp[0], derived); /* If string is too long, use hash value in hex representation (allow for - extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). + extra decoration, cf. gfc_build_class_symbol & gfc_get_derived_vtab). We need space to for 15 characters "__class_" + symbol name + "_%d_%da", where %d is the (co)rank which can be up to n = 15. */ if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) @@ -583,7 +583,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.u.derived = NULL; else { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; } @@ -684,7 +684,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) gfc_component *cmp; gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared); + vtab = gfc_get_derived_vtab (declared); for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { @@ -811,7 +811,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_symbol *vtab; gfc_component *c; - vtab = gfc_find_derived_vtab (comp->ts.u.derived); + vtab = gfc_get_derived_vtab (comp->ts.u.derived); for (c = vtab->ts.u.derived->components; c; c = c->next) if (strcmp (c->name, "_final") == 0) break; @@ -985,13 +985,14 @@ static void generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, const char *tname, gfc_component *vtab_final) { - gfc_symbol *final, *array, *nelem; + gfc_symbol *final, *array, *nelem, *skip_coarray; gfc_symbol *ptr = NULL, *idx = NULL; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code; char name[GFC_MAX_SYMBOL_LEN+1]; bool finalizable_comp = false; + bool expr_null_wrapper = false; gfc_expr *ancestor_wrapper = NULL; /* Search for the ancestor's finalizers. */ @@ -1002,7 +1003,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_symbol *vtab; gfc_component *comp; - vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); + vtab = gfc_get_derived_vtab (derived->components->ts.u.derived); for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) if (comp->name[0] == '_' && comp->name[1] == 'f') { @@ -1011,40 +1012,44 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, } } - /* No wrapper of the ancestor and no own FINAL subroutines and - allocatable components: Return a NULL() expression. */ + /* No wrapper of the ancestor and no own FINAL subroutines and allocatable + components: Return a NULL() expression; we defer this a bit to have have + an interface declaration. */ if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) && !derived->attr.alloc_comp && (!derived->f2k_derived || !derived->f2k_derived->finalizers) && !has_finalizer_component (derived)) - { - vtab_final->initializer = gfc_get_null_expr (NULL); - return; - } - - /* Check whether there are new allocatable components. */ - for (comp = derived->components; comp; comp = comp->next) - { - if (comp == derived->components && derived->attr.extension - && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + expr_null_wrapper = true; + else + /* Check whether there are new allocatable components. */ + for (comp = derived->components; comp; comp = comp->next) + { + if (comp == derived->components && derived->attr.extension + && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) continue; - if (comp->ts.type != BT_CLASS && !comp->attr.pointer - && (comp->attr.alloc_comp || comp->attr.allocatable - || (comp->ts.type == BT_DERIVED - && has_finalizer_component (comp->ts.u.derived)))) - finalizable_comp = true; - else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable) - finalizable_comp = true; - } + if (comp->ts.type != BT_CLASS && !comp->attr.pointer + && (comp->attr.allocatable + || (comp->ts.type == BT_DERIVED + && (comp->ts.u.derived->attr.alloc_comp + || has_finalizer_component (comp->ts.u.derived) + || (comp->ts.u.derived->f2k_derived + && comp->ts.u.derived->f2k_derived->finalizers))))) + finalizable_comp = true; + else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable) + finalizable_comp = true; + } /* If there is no new finalizer and no new allocatable, return with an expr to the ancestor's one. */ - if ((!derived->f2k_derived || !derived->f2k_derived->finalizers) - && !finalizable_comp) + if (!expr_null_wrapper && !finalizable_comp + && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) { + gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL + && ancestor_wrapper->expr_type == EXPR_VARIABLE); vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); + vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; return; } @@ -1057,12 +1062,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 3. Call the ancestor's finalizer. */ /* Declare the wrapper function; it takes an assumed-rank array - as argument. */ + and a VALUE logical as arguments. */ /* Set up the namespace. */ sub_ns = gfc_get_namespace (ns, 0); sub_ns->sibling = ns->contained; - ns->contained = sub_ns; + if (!expr_null_wrapper) + ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up the procedure symbol. */ @@ -1070,13 +1076,17 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_get_symbol (name, sub_ns, &final); sub_ns->proc_name = final; final->attr.flavor = FL_PROCEDURE; - final->attr.subroutine = 1; - final->attr.pure = 1; + final->attr.function = 1; + final->attr.pure = 0; + final->result = final; + final->ts.type = BT_INTEGER; + final->ts.kind = 4; final->attr.artificial = 1; - final->attr.if_source = IFSRC_DECL; + final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; gfc_set_sym_referenced (final); + gfc_commit_symbol (final); /* Set up formal argument. */ gfc_get_symbol ("array", sub_ns, &array); @@ -1096,6 +1106,37 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->formal->sym = array; gfc_commit_symbol (array); + /* Set up formal argument. */ + gfc_get_symbol ("skip_coarray", sub_ns, &skip_coarray); + skip_coarray->ts.type = BT_LOGICAL; + skip_coarray->ts.kind = 4; + skip_coarray->attr.flavor = FL_VARIABLE; + skip_coarray->attr.dummy = 1; + skip_coarray->attr.value = 1; + skip_coarray->attr.artificial = 1; + gfc_set_sym_referenced (skip_coarray); + final->formal->next = gfc_get_formal_arglist (); + final->formal->next->sym = skip_coarray; + gfc_commit_symbol (skip_coarray); + + /* Return with a NULL() expression but with an interface which has + the formal arguments. */ + if (expr_null_wrapper) + { + vtab_final->initializer = gfc_get_null_expr (NULL); + vtab_final->ts.interface = final; + return; + } + + + /* Set return value to 0. */ + last_code = XCNEW (gfc_code); + last_code->op = EXEC_ASSIGN; + last_code->loc = gfc_current_locus; + last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr2 = gfc_get_int_expr (4, NULL, 0); + sub_ns->code = last_code; + /* Obtain the size (number of elements) of "array" MINUS ONE, which is used in the scalarization. */ gfc_get_symbol ("nelem", sub_ns, &nelem); @@ -1107,7 +1148,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_commit_symbol (nelem); /* Generate: nelem = SIZE (array) - 1. */ - last_code = XCNEW (gfc_code); + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; last_code->op = EXEC_ASSIGN; last_code->loc = gfc_current_locus; @@ -1386,9 +1428,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->ext.actual = gfc_get_actual_arglist (); last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); + last_code->ext.actual->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (skip_coarray); } - gfc_commit_symbol (final); vtab_final->initializer = gfc_lval_expr_from_sym (final); vtab_final->ts.interface = final; } @@ -1419,10 +1462,10 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) } -/* Find (or generate) the symbol for a derived type's vtab. */ +/* Find or generate the symbol for a derived type's vtab. */ -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) +static gfc_symbol * +find_derived_vtab (gfc_symbol *derived, bool generate) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; @@ -1440,7 +1483,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - + get_unique_hashed_string (tname, derived); sprintf (name, "__vtab_%s", tname); @@ -1451,6 +1494,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (vtab == NULL) gfc_find_symbol (name, derived->ns, 0, &vtab); + if (!generate && !vtab) + return NULL; + if (vtab == NULL) { gfc_get_symbol (name, ns, &vtab); @@ -1464,7 +1510,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); sprintf (name, "__vtype_%s", tname); - + gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) { @@ -1509,7 +1555,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) parent = gfc_get_derived_super_type (derived); if (parent) { - parent_vtab = gfc_find_derived_vtab (parent); + parent_vtab = gfc_get_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); @@ -1627,9 +1673,6 @@ 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; @@ -1637,7 +1680,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. */ add_procs_to_declared_vtab (derived, vtype); @@ -1675,6 +1717,20 @@ cleanup: } +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, false); +} + + +gfc_symbol * +gfc_get_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, true); +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 4bba438..3b601bb 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3569,7 +3569,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) /* Make sure the vtab is present. */ - gfc_find_derived_vtab (rvalue->ts.u.derived); + gfc_get_derived_vtab (rvalue->ts.u.derived); /* Check rank remapping. */ if (rank_remap) @@ -4780,13 +4780,18 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, /* Variable not assignable from a PURE procedure but appears in variable definition context. */ - if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym)) + if (!pointer && gfc_impure_variable (sym)) { - if (context) + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + else if (gfc_pure (NULL)) + { + if (context) gfc_error ("Variable '%s' can not appear in a variable definition" " context (%s) at %L in PURE procedure", sym->name, context, &e->where); - return FAILURE; + return FAILURE; + } } if (!pointer && context && gfc_implicit_pure (NULL) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b3224aa..a6f501f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2956,6 +2956,7 @@ unsigned int gfc_hash_value (gfc_symbol *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **, bool); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); +gfc_symbol *gfc_get_derived_vtab (gfc_symbol *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 88689aa..b9fe030 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1830,7 +1830,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when the module variables are generated. */ - gfc_find_derived_vtab (actual->ts.u.derived); + gfc_get_derived_vtab (actual->ts.u.derived); if (actual->ts.type == BT_PROCEDURE) { diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 3f981d8..83a896a 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -945,7 +945,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (a); else if (a->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (a->ts.u.derived); + vtab = gfc_get_derived_vtab (a->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (a->ref); memset (a, '\0', sizeof (gfc_expr)); @@ -961,7 +961,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (mo); else if (mo->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (mo->ts.u.derived); + vtab = gfc_get_derived_vtab (mo->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (mo->ref); memset (mo, '\0', sizeof (gfc_expr)); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 5c5d381..f31e309 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -2195,7 +2195,8 @@ endType: if (c->attr.allocatable || (c->ts.type == BT_CLASS && c->attr.class_ok && CLASS_DATA (c)->attr.allocatable) - || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp)) + || (c->ts.type == BT_DERIVED && !c->attr.pointer + && c->ts.u.derived->attr.alloc_comp)) { allocatable = true; sym->attr.alloc_comp = 1; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f67c07f..60b6655 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -424,7 +424,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) @@ -6189,7 +6193,7 @@ resolve_typebound_function (gfc_expr* e) declared = ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_compcall (e, &name) == FAILURE) return FAILURE; @@ -6314,7 +6318,7 @@ resolve_typebound_subroutine (gfc_code *code) declared = expr->ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; @@ -7335,7 +7339,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ts = code->expr3->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; - gfc_find_derived_vtab (ts.u.derived); + gfc_get_derived_vtab (ts.u.derived); if (dimension) e = gfc_expr_to_initialize (e); } @@ -8524,7 +8528,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); new_st->expr1->value.function.actual->expr->where = code->loc; gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); - vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); + vtab = gfc_get_derived_vtab (body->ext.block.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -11220,11 +11224,7 @@ 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); + gfc_get_derived_vtab (derived); return result; } @@ -11784,7 +11784,7 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_result = SUCCESS; /* Make sure the vtab has been generated. */ - gfc_find_derived_vtab (derived); + gfc_get_derived_vtab (derived); if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, @@ -12338,7 +12338,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -12550,6 +12550,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.artificial) return; + if (sym->attr.artificial) + return; + if (sym->attr.flavor == FL_UNKNOWN || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic && !sym->attr.generic && !sym->attr.external diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c350c3b..8b36800 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7587,7 +7587,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 53c248d..5ec7e8d 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1211,7 +1211,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gfc_component *c = CLASS_DATA (sym); if (!c->ts.u.derived->backend_decl) { - gfc_find_derived_vtab (c->ts.u.derived); + gfc_get_derived_vtab (c->ts.u.derived); gfc_get_derived_type (sym->ts.u.derived); } } @@ -1488,10 +1488,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->attr.vtab || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0)) - { - TREE_READONLY (decl) = 1; - GFC_DECL_PUSH_TOPLEVEL (decl) = 1; - } + TREE_READONLY (decl) = 1; return decl; } @@ -1926,8 +1923,7 @@ build_function_decl (gfc_symbol * sym, bool global) /* Layout the function declaration and put it in the binding level of the current function. */ - if (global - || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0)) + if (global) pushdecl_top_level (fndecl); else pushdecl (fndecl); @@ -3439,7 +3435,54 @@ 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) + { + gfc_code *code; + + f->sym->attr.referenced = 1; + code = gfc_get_code (); + if (f->sym->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = gfc_get_logical_expr (4, NULL, false); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + 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); + gfc_free_statements (code); + + 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, @@ -3461,25 +3504,60 @@ 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_code *code; + gfc_symbol *vtab; + gfc_component *final; + + /* Make sure the vtab is available. */ + gfc_get_derived_vtab (f->sym->ts.u.derived); + final_expr = gfc_lval_expr_from_sym (f->sym); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + f->sym->attr.referenced = 1; + code = gfc_get_code (); + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = gfc_get_logical_expr (4, NULL, false); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + /* 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); } @@ -3789,14 +3867,15 @@ 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) { /* Initialize _vptr to declared type. */ - gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (sym->ts.u.derived); tree rhs; gfc_save_backend_locus (&loc); @@ -5433,10 +5512,7 @@ gfc_generate_function_code (gfc_namespace * ns) next = DECL_CHAIN (decl); DECL_CHAIN (decl) = NULL_TREE; - if (GFC_DECL_PUSH_TOPLEVEL (decl)) - pushdecl_top_level (decl); - else - pushdecl (decl); + pushdecl (decl); decl = next; } saved_function_decls = NULL_TREE; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 98634c3..a246943 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) #define VTABLE_EXTENDS_FIELD 2 #define VTABLE_DEF_INIT_FIELD 3 #define VTABLE_COPY_FIELD 4 +#define VTABLE_FINAL_FIELD 5 tree @@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl) } +tree +gfc_vtable_final_get (tree decl) +{ + return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD); +} + + #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD #undef VTABLE_HASH_FIELD @@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl) #undef VTABLE_EXTENDS_FIELD #undef VTABLE_DEF_INIT_FIELD #undef VTABLE_COPY_FIELD +#undef VTABLE_FINAL_FIELD /* Obtain the vptr of the last class reference in an expression. */ @@ -259,7 +268,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { /* In this case the vtab corresponds to the derived type and the vptr must point to it. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); + vtab = gfc_get_derived_vtab (e->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -664,9 +673,9 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (expr2->ts.type == BT_DERIVED) - vtab = gfc_find_derived_vtab (expr2->ts.u.derived); + vtab = gfc_get_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + vtab = gfc_get_derived_vtab (expr1->ts.u.derived); gcc_assert (vtab); rhs = gfc_get_expr (); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4b268b3..2fdcb0f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7273,7 +7273,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, - to_expr2, to_expr->ts); + to_expr, to_expr->ts); gfc_add_expr_to_block (&block, tmp); /* Assign (_data) pointers. */ @@ -7308,7 +7308,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -7339,7 +7339,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 204f069..a703dcc 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5097,7 +5097,7 @@ gfc_trans_allocate (gfc_code * code) if (ts->type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); gfc_init_se (&lse, NULL); lse.want_pointer = 1; @@ -5182,10 +5182,11 @@ gfc_trans_allocate (gfc_code * code) } else ppc = gfc_lval_expr_from_sym - (gfc_find_derived_vtab (rhs->ts.u.derived)); + (gfc_get_derived_vtab (rhs->ts.u.derived)); 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.... */ @@ -5345,13 +5346,88 @@ 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_code *code; + + 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"); + } + 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); + } + + code = gfc_get_code (); + if (al->expr->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else + 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 = gfc_get_logical_expr (4, NULL, + false); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + 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 (&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; @@ -5376,7 +5452,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. */ @@ -5389,7 +5465,7 @@ gfc_trans_deallocate (gfc_code *code) { /* Reset _vptr component to declared type. */ gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr); - gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (al->expr->ts.u.derived); gfc_add_vptr_component (lhs); rhs = gfc_lval_expr_from_sym (vtab); tmp = gfc_trans_pointer_assignment (lhs, rhs); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 3286a5a..798f866 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..6e1c34f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1077,21 +1077,77 @@ 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_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"); + } + 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) + final_expr = final->initializer; + } + } + + 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 + 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 = gfc_get_logical_expr (4, NULL, false); + 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 9818ceb..bd1e204 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,6 +348,7 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +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); @@ -822,7 +823,6 @@ struct GTY((variable_size)) lang_decl { #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node) -#define GFC_DECL_PUSH_TOPLEVEL(node) DECL_LANG_FLAG_7(node) #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node) /* An array descriptor. */ diff --git a/gcc/testsuite/gfortran.dg/finalize_4.f03 b/gcc/testsuite/gfortran.dg/finalize_4.f03 index 11e094f..512dd1e 100644 --- a/gcc/testsuite/gfortran.dg/finalize_4.f03 +++ b/gcc/testsuite/gfortran.dg/finalize_4.f03 @@ -1,4 +1,4 @@ -! { dg-do compile } +! { dg-do run } ! Parsing of finalizer procedure definitions. ! Check parsing of valid finalizer definitions. @@ -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" }