Hi all, with the priceless support of Tobias I've almost realized the patch for this PR. In attachment there's the second draft. During the regression test I have only one error with select_type_4.f90. The problem is in the destroy_list subroutine when it checks associated(node) after the first deallocate(node).
2012/6/5 Paul Richard Thomas <paul.richard.tho...@gmail.com>: > Hi Alessandro, > > I am glad to see that Janus is giving you a helping hand, in addition > to Tobias. I am so tied up with every aspect of life that gfortran is > not figuring much at all. > > When you clean up the patch, you might consider making this into a > separate function: > > + 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); > + } > > ... and using the function call to replace the corresponding call to > _copy in trans_allocate. > > I suspect that we are going to do this some more :-) > > Once we have the separate function, we could at later stage replace it > by a TREE_SSA version. > > Cheers > > Paul > > On 3 June 2012 12:15, Alessandro Fanfarillo <fanfarillo....@gmail.com> wrote: >>> Right, the problem is that the _free component is missing. Just as the >>> _copy component, _free should be present for *every* vtype, no matter >>> if there are allocatable components or not. If the _free component is >>> not needed, it should be initialized to EXPR_NULL. >> >> With an "empty" _free function for every type which does not have >> allocatable components the problem with dynamic_dispatch_4.f03 >> disappears :), thank you very much. In the afternoon I'll reorganize >> the code. >> >> Bye. >> >> Alessandro > > > > -- > The knack of flying is learning how to throw yourself at the ground and miss. > --Hitchhikers Guide to the Galaxy
Index: gcc/testsuite/gfortran.dg/class_19.f03 =================================================================== --- gcc/testsuite/gfortran.dg/class_19.f03 (revisione 188002) +++ gcc/testsuite/gfortran.dg/class_19.f03 (copia locale) @@ -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" 14 "original" } } ! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 (revisione 188002) +++ gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 (copia locale) @@ -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" 4 "original" } } ! { dg-final { cleanup-tree-dump "original" } } Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revisione 188002) +++ gcc/fortran/trans-stmt.c (copia locale) @@ -5341,7 +5341,12 @@ gfc_trans_deallocate (gfc_code *code) for (al = code->ext.alloc.list; al != NULL; al = al->next) { - gfc_expr *expr = gfc_copy_expr (al->expr); + gfc_expr *expr; + gfc_expr *ppc; + gfc_code *ppc_code; + gfc_actual_arglist *actual; + expr = gfc_copy_expr (al->expr); + ppc = gfc_copy_expr (expr); gcc_assert (expr->expr_type == EXPR_VARIABLE); if (expr->ts.type == BT_CLASS) @@ -5354,6 +5359,24 @@ gfc_trans_deallocate (gfc_code *code) 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) + { + gfc_add_vptr_component (ppc); + gfc_add_component_ref (ppc, "_free"); + 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) Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revisione 188002) +++ gcc/fortran/class.c (copia locale) @@ -717,6 +717,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) 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; + gfc_component *temp = NULL; + bool der_comp_alloc, comp_alloc, class_comp_alloc; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -907,6 +910,118 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.interface = copy; } + /* Add component _free. */ + der_comp_alloc = false; + comp_alloc = false; + 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.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 */ + if (free_proc->ts.interface && free_proc->initializer) + { + 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; + } + } + else + { + 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; + free->attr.pure = 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 +1050,10 @@ cleanup: 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 ();