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

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

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 945 bytes --]

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

[-- Attachment #2: draftPolyDealloc.txt --]
[-- Type: text/plain, Size: 6943 bytes --]

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)

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Janus Weil]

Hi Alessandro,

> I have realized a draft patch for the PR 46321, currently it works
> only with the explicit DEALLOCATE.

thanks for the patch! Some first comments without actually looking at
the patch in detail ...


> 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.

Right. You should certainly fix the "scan-tree-dump-times" checks (by
adjusting the numbers properly, and making sure that they are actually
what one would expect), in order to make them pass.


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

Sorry, I don't understand the last sentence. Why should it call some
"__free..." instead of "doit"? And why is that test case even affected
by your patch (you said it would only work with explicit DEALLOCATE,
which does not appear in that test case)?


> Regarding typebound_operator_9.f03, I don't know how to fix the patch...

Unfortunately that test case is rather large, so maybe you should
reduce it a bit to find the error (or just do some debugging in order
to find out where exactly it fails). Another possibility: Compare the
dump (using -fdump-tree-original) with and without the patch.


> The patch is written in a "raw" way due to my newbieness, so any
> suggestion is well accepted.

The patch actually gives a few warnings:

/home/jweil/gcc48/trunk/gcc/fortran/class.c: In function
‘gfc_find_derived_vtab’:
/home/jweil/gcc48/trunk/gcc/fortran/class.c:912:8: warning: ISO C90
forbids mixed declarations and code [-pedantic]
/home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: C++ style
comments are not allowed in ISO C90 [enabled by default]
/home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: (this will
be reported only once per input file) [enabled by default]

(and similar things in trans-stmt.c). You should definitely fix those.
Although a non-buildstrap build still works with those warnings, a
full bootstrap will fail.

Cheers,
Janus

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

Hi Janus,

> Sorry, I don't understand the last sentence. Why should it call some
> "__free..." instead of "doit"? And why is that test case even affected
> by your patch (you said it would only work with explicit DEALLOCATE,
> which does not appear in that test case)?

Yes, it is as I said... In
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=43986#c4 the doit() call
produces a segfault because r26 is 0 instead of the address of
__s_bar_mod_MOD_doit. With my patched version, the doit call is in
reality a _free __free_s_bar_mod_S_bar call. To better understand I
report a little portion (only the MAIN__) of the fdump-tree-original
and the testcase execution (hoping that it will be understandable...)

MAIN__ ()
{
  struct __class_foo_mod_Foo_p a;
  struct foo b;
  static struct s_bar c = {};
  static struct a_bar d = {};

  try
    {
      c.a = 0B;
      d.a.data = 0B;
      (struct __vtype_foo_mod_Foo *) a._vptr = &__vtab_foo_mod_Foo;
      a._data = &b;
      a._vptr->doit (&a);
      if (a._vptr->getit (&a) != 1)
        {
          _gfortran_abort ();
        }
      L.1:;
      (struct __vtype_foo_mod_Foo *) a._vptr = (struct
__vtype_foo_mod_Foo *) &__vtab_s_bar_mod_S_bar;
      a._data = (struct foo *) &c;
      a._vptr->doit (&a); IT REALLY WANTS TO CALL THE DOIT FUNCTION!
      if (a._vptr->getit (&a) != 2)
        {
          _gfortran_abort ();
        }
      L.2:;
      (struct __vtype_foo_mod_Foo *) a._vptr = (struct
__vtype_foo_mod_Foo *) &__vtab_a_bar_mod_A_bar;
      a._data = (struct foo *) &d;
      a._vptr->doit (&a);
      if (a._vptr->getit (&a) != 3)
        {
          _gfortran_abort ();
        }
      L.3:;
    }
  finally
    {
      if (d.a.data != 0B)
        {
          __builtin_free ((void *) d.a.data);
        }
      d.a.data = 0B;
      if (c.a != 0B)
        {
          __builtin_free ((void *) c.a);
        }
      c.a = 0B;
    }
}

An now the testcase execution with gdb:

Breakpoint 1, MAIN__ () at dynamic_dispatch_4.f03:82
82	  type(s_bar), target :: c
(gdb) next
83	  type(a_bar), target :: d
(gdb)
85	  a => b
(gdb)
86	  call a%doit
(gdb)
87	  if (a%getit () .ne. 1) call abort
(gdb)
88	  a => c
(gdb) step
89	  call a%doit
(gdb)
s_bar_mod::__free_s_bar_mod_S_bar (tofree=...) at dynamic_dispatch_4.f03:43
43	    class(s_bar) :: a

I don't know if I got it across...

> The patch actually gives a few warnings:

Ok, thanks. I always use bootstrap and it works but I never look at
the compile result (unless it doesn't compile...)

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Janus Weil]

Hi,

>> Sorry, I don't understand the last sentence. Why should it call some
>> "__free..." instead of "doit"? And why is that test case even affected
>> by your patch (you said it would only work with explicit DEALLOCATE,
>> which does not appear in that test case)?
>
> Yes, it is as I said... In
> http://gcc.gnu.org/bugzilla/show_bug.cgi?id=43986#c4 the doit() call
> produces a segfault because r26 is 0 instead of the address of
> __s_bar_mod_MOD_doit. With my patched version, the doit call is in
> reality a _free __free_s_bar_mod_S_bar call.

huh, this is strange, indeed. I guess it means that something is
messed up in the vtable (some sort of offset?). We try to call one
virtual function, but we get another. Since this problem was already
seen in PR43986, it is probably a case of your patch uncovering an
existing bug. I'll try to look into this problem soon ...

Cheers,
Janus

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Tobias Burnus]

Janus Weil wrote:
> The patch actually gives a few warnings:

Looking at those warnings, they seem to be valid C++ but invalid C89. As 
Stages 2 and 3 are, by default, compiled by C++, I assume that 
Alessandro does not see those.

By contrast, I assume that you (Janus) build GCC with the C compiler, 
i.e. you configure with --disable-build-poststage1-with-cxx.

Thus, a default boot strap,  shouldn't fail. Nonetheless, it is useful 
to keep compatibility with C and bootstrapping with 
--disable-build-poststage1-with-cxx.Hence, the warnings should be fixed. 
(Bootstrapping implies -Werror.)

Tobias

> /home/jweil/gcc48/trunk/gcc/fortran/class.c: In function
> ‘gfc_find_derived_vtab’:
> /home/jweil/gcc48/trunk/gcc/fortran/class.c:912:8: warning: ISO C90
> forbids mixed declarations and code [-pedantic]
> /home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: C++ style
> comments are not allowed in ISO C90 [enabled by default]
> /home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: (this will
> be reported only once per input file) [enabled by default]
>
> (and similar things in trans-stmt.c). You should definitely fix those.
> Although a non-buildstrap build still works with those warnings, a
> full bootstrap will fail.

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Tobias Burnus]

Alessandro Fanfarillo wrote:
> 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().

That kind of makes sense: "foo" has no allocatable components while 
"s_bar" has. Seemingly, "foo" has no "_free" component - and thus, the 
first entry in "vtab" after _hash, _size, _extends, _def_init and _copy 
is "doit". However, s_bar has at that position not "doit" but "_free".

My impression is that you do not add a
   "_free => null()"  (EXPR_NULL)
in the case that there are no allocatable components in the type or its 
parents.

Side note: In class.c, please update the comment at the top by 
mentioning _free after the description of "_copy".

Tobias

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Janus Weil]

Hi,

> By contrast, I assume that you (Janus) build GCC with the C compiler, i.e.
> you configure with --disable-build-poststage1-with-cxx.

actually I used --disable-bootstrap, which also has the effect that
gfortran is built with the C compiler.


> Thus, a default boot strap,  shouldn't fail. Nonetheless, it is useful to
> keep compatibility with C and bootstrapping with
> --disable-build-poststage1-with-cxx.Hence, the warnings should be fixed.
> (Bootstrapping implies -Werror.)

Right. I'm not sure what the further plans are for GCC regarding the C
vs C++ issue, but as long as GCC can still be built with a C compiler,
one should probably avoid unnecessary C++isms.

Cheers,
Janus



>> /home/jweil/gcc48/trunk/gcc/fortran/class.c: In function
>> ‘gfc_find_derived_vtab’:
>> /home/jweil/gcc48/trunk/gcc/fortran/class.c:912:8: warning: ISO C90
>> forbids mixed declarations and code [-pedantic]
>> /home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: C++ style
>> comments are not allowed in ISO C90 [enabled by default]
>> /home/jweil/gcc48/trunk/gcc/fortran/class.c:932:7: warning: (this will
>> be reported only once per input file) [enabled by default]
>>
>> (and similar things in trans-stmt.c). You should definitely fix those.
>> Although a non-buildstrap build still works with those warnings, a
>> full bootstrap will fail.

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Janus Weil]

2012/6/2 Tobias Burnus <burnus@net-b.de>:
> Alessandro Fanfarillo wrote:
>>
>> 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().
>
>
> That kind of makes sense: "foo" has no allocatable components while "s_bar"
> has. Seemingly, "foo" has no "_free" component - and thus, the first entry
> in "vtab" after _hash, _size, _extends, _def_init and _copy is "doit".
> However, s_bar has at that position not "doit" but "_free".

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.

Cheers,
Janus

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

> 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

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Paul Richard Thomas]

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

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 2337 bytes --]

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

[-- Attachment #2: newDeallocatePatch.txt --]
[-- Type: text/plain, Size: 7436 bytes --]

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

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1974 bytes --]

Alessandro Fanfarillo wrote:
> 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).

--- 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);
...
+      if (expr->symtree->n.sym->ts.type == BT_CLASS)


I'd prefer:

gfc_expr *ppc = NULL;
...
if (expr->ts.type == BT_CLASS)
   ppc = gfc_copy_expr (expr);
...
if (ppc)
   ...

Namely: Only copy the expression if needed.

Additionally, the check "if (expr->symtree->n.sym->ts.type == BT_CLASS)" 
is wrong. For instance, for
   type(t) :: x
   deallocate(x%class)
it won't trigger, but it should.

Actually, I think a cleaner version would be:

if (al->expr->ts.type == BT_CLASS)
   {
     gfc_expr *ppc;
     ppc = gfc_copy_expr (al->expr);

  * * *

Furthermore, I think you call _free + free for the same component for:

type t
    integer, allocatable :: x
end type t
class(t), allocatable :: y
...
deallocate (y)

* * *

Regarding your code: You assume that "al->expr" points to an allocated 
variable, that's not the always the case - hence, select_type_4.f90 fails.

* * *

You always create a _free function; I wonder whether it makes sense to 
use _vtab->free with NULL in case that no _free is needed.

  * * *

Attached an updated version, which does that all. No guarantee that it 
works correctly, but it should at least fix select_type_4.f90.

Tobias

[-- Attachment #2: new.diff --]
[-- Type: text/x-patch, Size: 7906 bytes --]

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index c71aa4a..8224f45 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -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 ();
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 323fca3..e2faeb9 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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,50 @@ 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);
+	  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,
+				  se.expr,
+				  build_int_cst (TREE_TYPE (se.expr), 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 +5423,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.  */
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 3313be9..9320f39 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1083,14 +1083,6 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
       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,

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

Thank you for the review, with this patch I get some ICEs during the
regstest with:

gfortran.dg/coarray/poly_run_3.f90
gfortran.dg/elemental_optional_args_5.f03
gfortran.dg/select_type_26.f03
gfortran.dg/select_type_27.f03
gfortran.dg/class_48.f90
gfortran.dg/class_allocate_10.f03
gfortran.dg/class_allocate_8.f03
gfortran.dg/class_array_1.f03
gfortran.dg/class_array_2.f03
gfortran.dg/assumed_type_2.f90
gfortran.dg/class_array_9.f03
gfortran.dg/coarray_lib_alloc_2.f90

I've debugged only the first 2 and the problem seems to be related
with "tmp =  fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); "
in trans-stmt.c at line 5376. The ICE message is the following:

$ gcc/bin/gfortran -c elemental_optional_args_5.f03
elemental_optional_args_5.f03: In function ‘MAIN__’:
elemental_optional_args_5.f03:220:0: internal compiler error: in
build_int_cst_wide, at tree.c:1219
 deallocate (taa, tpa, caa, cpa)
 ^
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.



2012/6/10 Tobias Burnus <burnus@net-b.de>:
> Alessandro Fanfarillo wrote:
>>
>> 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).
>
>
> --- 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);
> ...
> +      if (expr->symtree->n.sym->ts.type == BT_CLASS)
>
>
> I'd prefer:
>
> gfc_expr *ppc = NULL;
> ...
> if (expr->ts.type == BT_CLASS)
>  ppc = gfc_copy_expr (expr);
> ...
> if (ppc)
>  ...
>
> Namely: Only copy the expression if needed.
>
> Additionally, the check "if (expr->symtree->n.sym->ts.type == BT_CLASS)" is
> wrong. For instance, for
>  type(t) :: x
>  deallocate(x%class)
> it won't trigger, but it should.
>
> Actually, I think a cleaner version would be:
>
> if (al->expr->ts.type == BT_CLASS)
>  {
>    gfc_expr *ppc;
>    ppc = gfc_copy_expr (al->expr);
>
>  * * *
>
> Furthermore, I think you call _free + free for the same component for:
>
> type t
>   integer, allocatable :: x
> end type t
> class(t), allocatable :: y
> ...
> deallocate (y)
>
> * * *
>
> Regarding your code: You assume that "al->expr" points to an allocated
> variable, that's not the always the case - hence, select_type_4.f90 fails.
>
> * * *
>
> You always create a _free function; I wonder whether it makes sense to use
> _vtab->free with NULL in case that no _free is needed.
>
>  * * *
>
> Attached an updated version, which does that all. No guarantee that it works
> correctly, but it should at least fix select_type_4.f90.
>
> Tobias

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Tobias Burnus]

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

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

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 <burnus@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

Re: [Fortran, DRAFT patch] PR 46321 - [OOP] Polymorphic deallocation

[Alessandro Fanfarillo]

[-- Attachment #1: Type: text/plain, Size: 2054 bytes --]

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.gcc@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 <burnus@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

[-- Attachment #2: patch_Deallocate_INTENTOUT.txt --]
[-- Type: text/plain, Size: 11187 bytes --]

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