Dear all,
I have realized a draft patch for the PR 46321, currently it works
only with the explicit DEALLOCATE.
Running the regression tests it doesn't pass the following:
- gfortran.dg/class_19.f03 (too much "__builtin_free")
- gfortran.dg/auto_dealloc_2.f90 (too much "__builtin_free")
- gfortran.dg/dynamic_dispatch_4.f03 (free on invalid pointer)
- gfortran.dg/typebound_operator_9.f03 (fails during the execution test)
The first two tests fail due to the introduction of "__builtin_free"
in the freeing functions, so it is not a problem.
The gfortran.dg/dynamic_dispatch_4.f03 had this problem in the past
(http://gcc.gnu.org/bugzilla/show_bug.cgi?id=43986); currently it
calls the __free_s_bar_mod_S_bar function instead of the proper
doit().
Regarding typebound_operator_9.f03, I don't know how to fix the patch...
The patch is written in a "raw" way due to my newbieness, so any
suggestion is well accepted.
Regards.
Alessandro
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)
