Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revisione 188002) +++ gcc/fortran/class.c (copia locale) @@ -717,6 +717,7 @@ gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; + gfc_symbol *free = NULL, *tofree = NULL; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -907,6 +908,119 @@ c->ts.interface = copy; } + /* Add component _free. */ + gfc_component *temp = NULL; + bool der_comp_alloc = false, comp_alloc = false; + bool class_comp_alloc = false; + for (temp = derived->components; temp; temp = temp->next) + { + if (temp == derived->components && derived->attr.extension) + continue; + + if (temp->ts.type == BT_DERIVED + && !temp->attr.pointer + && (temp->attr.alloc_comp || temp->attr.allocatable)) + der_comp_alloc = true; + else if (temp->ts.type != BT_DERIVED + && !temp->attr.pointer + && (temp->attr.alloc_comp + || temp->attr.allocatable)) + comp_alloc = true; + else if (temp->ts.u.derived + && temp->ts.type == BT_CLASS + && CLASS_DATA (temp) + //&& (CLASS_DATA (temp)->attr.class_pointer + // || CLASS_DATA (temp)->attr.allocatable)) + && CLASS_DATA (temp)->attr.allocatable) + class_comp_alloc = true; + } + if (derived->attr.extension + && (!der_comp_alloc && !comp_alloc && !class_comp_alloc)) + { + gfc_component *parent = derived->components; + gfc_component *free_proc = NULL; + gfc_symbol *vtab2 = NULL; + gfc_expr *tmp1 = NULL, *tmp2 = NULL; + vtab2 = gfc_find_derived_vtab (parent->ts.u.derived); + + for (free_proc = vtab2->ts.u.derived->components; + free_proc; free_proc = free_proc->next) + if (free_proc->name[0] == '_' + && free_proc->name[1] == 'f') + break; + + if (!free_proc) + goto end_vtab; + + if (gfc_add_component (vtype, "_free", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + /* Not sure about this part */ + tmp1 = gfc_lval_expr_from_sym (free_proc->ts.interface); + tmp2 = gfc_copy_expr (tmp1); + c->initializer = tmp2; + c->ts.interface = tmp2->symtree->n.sym; + goto end_vtab; + + } + + if (derived->attr.alloc_comp || der_comp_alloc + || class_comp_alloc) + { + gfc_alloc *head = NULL; + if (gfc_add_component (vtype, "_free", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + if (derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Set up namespace. */ + gfc_namespace *sub_ns2 = gfc_get_namespace (ns, 0); + sub_ns2->sibling = ns->contained; + ns->contained = sub_ns2; + sub_ns2->resolved = 1; + /* Set up procedure symbol. */ + sprintf (name, "__free_%s", tname); + gfc_get_symbol (name, sub_ns2, &free); + sub_ns2->proc_name = free; + free->attr.flavor = FL_PROCEDURE; + free->attr.subroutine = 1; + free->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + free->attr.elemental = 1; + if (ns->proc_name->attr.flavor == FL_MODULE) + free->module = ns->proc_name->name; + gfc_set_sym_referenced (free); + /* Set up formal arguments. */ + gfc_get_symbol ("tofree", sub_ns2, &tofree); + tofree->ts.type = BT_DERIVED; + tofree->ts.u.derived = derived; + tofree->attr.flavor = FL_VARIABLE; + tofree->attr.dummy = 1; + tofree->attr.intent = INTENT_OUT; + gfc_set_sym_referenced (tofree); + free->formal = gfc_get_formal_arglist (); + free->formal->sym = tofree; + /* Set up code. */ + sub_ns2->code = gfc_get_code (); + sub_ns2->code->op = EXEC_NOP; + head = gfc_get_alloc (); + head->expr = gfc_lval_expr_from_sym (tofree); + sub_ns2->code->ext.alloc.list = head; + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (free); + c->ts.interface = free; + } + } +end_vtab: /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); } @@ -935,6 +1049,10 @@ gfc_commit_symbol (src); if (dst) gfc_commit_symbol (dst); + if (free) + gfc_commit_symbol (free); + if (tofree) + gfc_commit_symbol (tofree); } else gfc_undo_symbols (); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revisione 188002) +++ gcc/fortran/trans-stmt.c (copia locale) @@ -5343,6 +5343,11 @@ { gfc_expr *expr = gfc_copy_expr (al->expr); gcc_assert (expr->expr_type == EXPR_VARIABLE); + gfc_expr *ppc; + gfc_code *ppc_code; + gfc_actual_arglist *actual; + gfc_component *free_proc = NULL; + gfc_symbol *vtab2 = NULL, *tmp_sym = NULL; if (expr->ts.type == BT_CLASS) gfc_add_data_component (expr); @@ -5354,6 +5359,43 @@ se.descriptor_only = 1; gfc_conv_expr (&se, expr); + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (expr); + if (expr->symtree->n.sym->ts.type == BT_CLASS + && expr->symtree->n.sym->tlink + && expr->symtree->n.sym->tlink->ts.u.derived) + { + if (expr->ref && expr->ref->u.c.component->ts.type == BT_CLASS) + { + tmp_sym = expr->ref->u.c.component->ts.u.derived; + tmp_sym = tmp_sym->components->ts.u.derived; + } + else + { + tmp_sym = expr->symtree->n.sym->tlink->ts.u.derived; + } + vtab2 = gfc_find_derived_vtab (tmp_sym); + vtab2 = vtab2->ts.u.derived; + for (free_proc = vtab2->components; + free_proc; free_proc = free_proc->next) + if (free_proc->name[0] == '_' + && free_proc->name[1] == 'f') + break; + if (free_proc) + { + ppc = gfc_copy_expr(free_proc->initializer); + ppc_code = gfc_get_code (); + ppc_code->resolved_sym = ppc->symtree->n.sym; + ppc_code->resolved_sym->attr.elemental = 1; + ppc_code->ext.actual = actual; + ppc_code->expr1 = ppc; + ppc_code->op = EXEC_CALL; + tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); + gfc_free_statements (ppc_code); + gfc_add_expr_to_block (&block, tmp); + } + } + if (expr->rank || gfc_is_coarray (expr)) { if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)