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 <[email protected]>:
> 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 <[email protected]>:
>> 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 ();
