Dear all, in attachment the new draft which also supports the polymorphic deallocation via INTENT(OUT). Tomorrow I'll try to realize a draft for the deallocation at the end of the scope.
Regards 2012/6/12 Alessandro Fanfarillo <fanfarillo....@gmail.com>: > I don't know if there's already a PR but I get an ICE compiling this > with a non-patched version. If x is not an array everything goes ok. > > 2012/6/11 Tobias Burnus <bur...@net-b.de>: >> On 06/11/2012 11:24 AM, Alessandro Fanfarillo wrote: >>> >>> gfortran.dg/coarray/poly_run_3.f90 >> >> >> That one fails because I for forgot that se.expr in gfc_trans_deallocate >> contains the descriptor and not the pointer to the data. That's fixed by: >> >> tmp = se.expr; >> if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) >> { >> tmp = gfc_conv_descriptor_data_get (tmp); >> STRIP_NOPS (tmp); >> >> } >> tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, >> tmp, build_int_cst (TREE_TYPE (tmp), 0)); >> >> However, it still fails for the >> >> type t >> integer, allocatable :: comp >> end type t >> contains >> subroutine foo(x) >> class(t), allocatable, intent(out) :: x(:) >> end subroutine >> end >> >> (The intent(out) causes automatic deallocation.) The backtrace does not >> really point to some code which the patch touched; it shouldn't be affected >> by the class.c changes and gfc_trans_deallocate does not seem to be entered. >> >> While I do not immediately see why it fails, I wonder whether it is due to >> the removed "else if ... BT_CLASS)" case in >> gfc_deallocate_scalar_with_status. In any case, the change to >> gfc_trans_deallocate might be also needed for >> gfc_deallocate_scalar_with_status. At least, automatic deallocation (with >> intent(out) or when leaving the scope) does not seem to go through >> gfc_trans_deallocate but only through gfc_deallocate_scalar_with_status. >> >> Tobias
Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revisione 188511) +++ gcc/fortran/trans-decl.c (copia locale) @@ -3423,6 +3423,63 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra gfc_init_block (&init); for (f = proc_sym->formal; f; f = f->next) 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) + { + gfc_expr *expr, *ppc; + gfc_se se, free_se; + gfc_code *ppc_code; + gfc_actual_arglist *actual; + tree cond; + f->sym->attr.referenced = 1; + expr = gfc_lval_expr_from_sym(f->sym); + gcc_assert (expr->expr_type == EXPR_VARIABLE); + + if (expr->ts.type == BT_CLASS) + gfc_add_data_component (expr); + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr); + ppc = gfc_lval_expr_from_sym(f->sym);; + gfc_add_vptr_component (ppc); + gfc_add_component_ref (ppc, "_free"); + gfc_init_se (&free_se, NULL); + free_se.want_pointer = 1; + gfc_conv_expr (&free_se, ppc); + tmp = se.expr; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + { + tmp = gfc_conv_descriptor_data_get (tmp); + STRIP_NOPS (tmp); + } + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + free_se.expr, + build_int_cst (TREE_TYPE (free_se.expr), 0)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, tmp); + + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (expr); + + 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); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&init, tmp); + gfc_free_statements (ppc_code); + } + else if (f->sym && f->sym->attr.intent == INTENT_OUT && !f->sym->attr.pointer && f->sym->ts.type == BT_DERIVED) { @@ -3446,7 +3503,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra else if (f->sym->value) gfc_init_default_dt (f->sym, &init, true); } - else if (f->sym && f->sym->attr.intent == INTENT_OUT + /*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) @@ -3468,7 +3525,7 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wra } gfc_add_expr_to_block (&init, tmp); - } + }*/ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); } Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (revisione 188511) +++ gcc/fortran/trans.c (copia locale) @@ -1083,14 +1083,6 @@ gfc_deallocate_scalar_with_status (tree pointer, t tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - else if (ts.type == BT_CLASS - && ts.u.derived->components->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); - gfc_add_expr_to_block (&non_null, tmp); - } tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revisione 188511) +++ gcc/fortran/trans-stmt.c (copia locale) @@ -5341,7 +5341,8 @@ 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; + expr = gfc_copy_expr (al->expr); gcc_assert (expr->expr_type == EXPR_VARIABLE); if (expr->ts.type == BT_CLASS) @@ -5354,9 +5355,55 @@ gfc_trans_deallocate (gfc_code *code) se.descriptor_only = 1; gfc_conv_expr (&se, expr); + if (al->expr->ts.type == BT_CLASS) + { + gfc_expr *ppc; + gfc_code *ppc_code; + gfc_actual_arglist *actual; + tree cond; + gfc_se free_se; + + ppc = gfc_copy_expr (al->expr); + gfc_add_vptr_component (ppc); + gfc_add_component_ref (ppc, "_free"); + + gfc_init_se (&free_se, NULL); + free_se.want_pointer = 1; + gfc_conv_expr (&free_se, ppc); + tmp = se.expr; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) + { + tmp = gfc_conv_descriptor_data_get (tmp); + STRIP_NOPS (tmp); + } + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + free_se.expr, + build_int_cst (TREE_TYPE (free_se.expr), 0)); + tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), 0)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, tmp); + + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (expr); + + 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); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + gfc_free_statements (ppc_code); + } + if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + if (al->expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) { gfc_ref *ref; gfc_ref *last = NULL; @@ -5381,7 +5428,7 @@ gfc_trans_deallocate (gfc_code *code) else { tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, - expr, expr->ts); + expr, al->expr->ts); gfc_add_expr_to_block (&se.pre, tmp); /* Set to zero after deallocation. */ Index: gcc/fortran/class.c =================================================================== --- gcc/fortran/class.c (revisione 188511) +++ gcc/fortran/class.c (copia locale) @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see * _extends: A pointer to the vtable entry of the parent derived type. * _def_init: A pointer to a default initialized variable of this type. * _copy: A procedure pointer to a copying procedure. + * _free: A procedure pointer to a free procedure. After these follow procedure pointer components for the specific type-bound procedures. */ @@ -717,6 +718,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 comp_alloc; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) @@ -907,6 +911,101 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.interface = copy; } + /* Add component _free. */ + comp_alloc = false; + + for (temp = derived->components; temp; temp = temp->next) + { + if (temp == derived->components && derived->attr.extension) + continue; + + if (temp->ts.type != BT_CLASS + && !temp->attr.pointer + && (temp->attr.alloc_comp || temp->attr.allocatable)) + comp_alloc = true; + else if (temp->ts.type == BT_CLASS + && CLASS_DATA (temp) + && CLASS_DATA (temp)->attr.allocatable) + comp_alloc = true; + } + + 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.alloc_comp || derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else if (derived->attr.extension && !comp_alloc + && !derived->components->attr.abstract) + { + /* No new allocatable components: Link to the parent's _free. */ + gfc_component *parent = derived->components; + gfc_component *free_proc = NULL; + gfc_symbol *vtab2 = 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; + gcc_assert (free_proc); + + c->initializer = gfc_copy_expr (free_proc->initializer); + c->ts.interface = free_proc->ts.interface; + } + else + { + gfc_alloc *head = NULL; + + /* Create _free function. Set up its 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; + } + /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); } @@ -935,6 +1034,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 ();