Patchwork [Fortran,DRAFT] PR 46321 - [OOP] Polymorphic deallocation

login
register
mail settings
Submitter Alessandro Fanfarillo
Date June 9, 2012, 9:53 a.m.
Message ID <CAHqFgjXKqBQGDErzqCUz-iDi70o+rZQnmNrm88BBHJHWtMbPQw@mail.gmail.com>
Download mbox | patch
Permalink /patch/163907/
State New
Headers show

Comments

Alessandro Fanfarillo - June 9, 2012, 9:53 a.m.
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.thomas@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.gcc@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

Patch

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 ();