Patchwork [fortran] PR46897 - [OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign

login
register
mail settings
Submitter Paul Richard Thomas
Date Aug. 13, 2012, 1:37 p.m.
Message ID <CAGkQGiLUJSqmV-CdnbiK=iVMsfgP62a3X28kDsCsXUDjPTNa3A@mail.gmail.com>
Download mbox | patch
Permalink /patch/176942/
State New
Headers show

Comments

Paul Richard Thomas - Aug. 13, 2012, 1:37 p.m.
Dear All,

Please find attached a patch and testcase for the above PR.  The
comment before generate_component_assignments explains the need for
the patch, which itself is fairly self explanatory.

Bootstrapped and regtested on Fc9/x86_64 - OK for trunk?

Best regards

Paul and Alessandro.

2012-08-13   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
	     Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* resolve.c (add_comp_ref): New function.
	(generate_component_assignments): New function that calls
	add_comp_ref.
	(resolve_code): Call generate_component_assignments.

2012-08-13   Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com>
	     Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46897
	* gfortran.dg/defined_assignment_1.f90: New test.
Mikael Morin - Aug. 13, 2012, 6:16 p.m.
Hello Paul,

I think there are a couple of bugs not triggered by the single component
types in the test. See below.

On 13/08/2012 15:37, Paul Richard Thomas wrote:
> + 
> +       /* Go through the code chain eliminating all but calls to
> + 	 typebound procedures. Since we have been through
> + 	 resolve_typebound_subroutine. */
> +       for (; this_code; this_code = this_code->next)
> + 	{
> + 	  if (this_code->op == EXEC_ASSIGN_CALL)
> + 	    {
> + 	      gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym;
> + 	      /* Check that there is a defined assignment.  If so, then
> + 	         resolve the call.  */
> + 	      if (fsym->ts.type == BT_CLASS
> + 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
> + 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
> + 			->tb_op[INTRINSIC_ASSIGN])
> + 		{
> + 		  resolve_call (this_code);
> + 		  goto next;
> + 		}
> + 	    }
> + 
> + 	  next = this_code->next;
> + 	  if (this_code == root)
> + 	    root = next;
> + 	  else
> + 	    previous->next = next;
> + 
> + 	  next = this_code;
> + 	  next->next = NULL;
> + 	  gfc_free_statements (next);
This frees `this_code', but `this_code' is used to iterate the loop and
below.

> + 	next:
> + 	  previous = this_code;
This could be moved to the only next caller (`previous' doesn't need to
be updated if `this_code' is removed) to fix one usage of `this_code' :-).

> + 	}
> + 
> +       /* Now attach the remaining code chain to the input code. Step on
> + 	 to the end of the new code since resolution is complete.  */
This tells me that you know what you do...

> +       if (root)
> + 	{
> + 	  next = (*code)->next;
> + 	  (*code)->next = root;
> + 	  for (;root; root = root->next)
> + 	    if (!root->next)
> + 	      break;
> + 	  root->next = next;
> + 	  *code = root;
> + 	}
... but I have the feeling that this makes (*code) unreachable and that
that's wrong. Shouldn't it be "root->next = *code;" ?
Maybe you want to remove (*code) at the first iteration (as it contains
the whole structure assignment), but in the next iteration, it contains
the first typebound call, etc, doesn't it?

By the way I'm not sure we can keep the whole structure assignment to
handle default assignment:
if we do it after the typebound calls, we overwrite their job so we have
to do it before.
However, if we do it before, we also overwrite components to be assigned
with a typebound call, and this can have some side effects as the LHS's
argument can be INTENT(INOUT).

Thoughts?
Mikael
Paul Richard Thomas - Aug. 14, 2012, 5:03 a.m.
Dear Mikael,

> I think there are a couple of bugs not triggered by the single component
> types in the test. See below.

Yes, you are right.  We should have tested multiple components... my fault!

> This could be moved to the only next caller (`previous' doesn't need to
> be updated if `this_code' is removed) to fix one usage of `this_code' :-).

That's right... I'll make it so.

> ... but I have the feeling that this makes (*code) unreachable and that
> that's wrong. Shouldn't it be "root->next = *code;" ?

No.  That caused the regression that I mentioned.  (*code) is
resolved, at entry.  resolve_code steps on to (*code)->next.

> if we do it after the typebound calls, we overwrite their job so we have
> to do it before.

This is what is done.

> However, if we do it before, we also overwrite components to be assigned
> with a typebound call, and this can have some side effects as the LHS's
> argument can be INTENT(INOUT).

This might be so but it is what the standard dictates should
happen.... isn't it?

Thanks for the review.  I believe, in summary, that I should handle
'this_code' consistently so that multiple component defined
assignments work correctly.  I should also verify that pointers do
what they are supposed to do, although it is rather trivial.

Cheers

Paul
Alessandro Fanfarillo - Aug. 14, 2012, 6:57 a.m.
Dear Paul,
Dear all,

I tried to compile the check_compiler_for_memory_leaks.F90 file
provided by Damian and it produces a segfault error. May be the
problem is related with add_comp_ref.

Regards

Alessandro (from Malta)

2012/8/14 Paul Richard Thomas <paul.richard.thomas@gmail.com>
>
> Dear Mikael,
>
> > I think there are a couple of bugs not triggered by the single component
> > types in the test. See below.
>
> Yes, you are right.  We should have tested multiple components... my
> fault!
>
> > This could be moved to the only next caller (`previous' doesn't need to
> > be updated if `this_code' is removed) to fix one usage of `this_code'
> > :-).
>
> That's right... I'll make it so.
>
> > ... but I have the feeling that this makes (*code) unreachable and that
> > that's wrong. Shouldn't it be "root->next = *code;" ?
>
> No.  That caused the regression that I mentioned.  (*code) is
> resolved, at entry.  resolve_code steps on to (*code)->next.
>
> > if we do it after the typebound calls, we overwrite their job so we have
> > to do it before.
>
> This is what is done.
>
> > However, if we do it before, we also overwrite components to be assigned
> > with a typebound call, and this can have some side effects as the LHS's
> > argument can be INTENT(INOUT).
>
> This might be so but it is what the standard dictates should
> happen.... isn't it?
>
> Thanks for the review.  I believe, in summary, that I should handle
> 'this_code' consistently so that multiple component defined
> assignments work correctly.  I should also verify that pointers do
> what they are supposed to do, although it is rather trivial.
>
> Cheers
>
> Paul




--

Dott. Alessandro Fanfarillo
Verificatore Ellisse
Cell: 339/2428012
Email: alessandro.fanfarillo@gmail.com
Mikael Morin - Aug. 14, 2012, 8:42 a.m.
On 14/08/2012 07:03, Paul Richard Thomas wrote:
>> However, if we do it before, we also overwrite components to be assigned
>> with a typebound call, and this can have some side effects as the LHS's
>> argument can be INTENT(INOUT).
> 
> This might be so but it is what the standard dictates should
> happen.... isn't it?
> 
It dictates that the components should be assigned one by one (by either
defined or intrinsic assignment), which I don't see as strictly
equivalent to a whole structure assignment followed by typebound calls
(for components needing it).

Mikael
Mikael Morin - Aug. 14, 2012, 8:58 a.m.
On 14/08/2012 07:03, Paul Richard Thomas wrote:
>> ... but I have the feeling that this makes (*code) unreachable and that
>> that's wrong. Shouldn't it be "root->next = *code;" ?
> 
> No.  That caused the regression that I mentioned.  (*code) is
> resolved, at entry.  resolve_code steps on to (*code)->next.
> 
Yes, OK. Double pointers are really on the limits of my spirit.

Mikael

Patch

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 190338)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 9485,9490 ****
--- 9485,9614 ----
  }
  
  
+ /* Add a component reference onto an expression.  */
+ 
+ static void
+ add_comp_ref (gfc_expr *e, gfc_component *c)
+ {
+   gfc_ref **ref;
+   ref = &(e->ref);
+   while (*ref)
+     ref = &((*ref)->next);
+   *ref = gfc_get_ref();
+   (*ref)->type = REF_COMPONENT;
+   (*ref)->u.c.sym = c->ts.u.derived;
+   (*ref)->u.c.component = c;
+   e->ts = c->ts;
+ }
+ 
+ 
+ /* Implement 7.2.1.3 of the F08 standard:
+    "An intrinsic assignment where the variable is of derived type is
+    performed as if each component of the variable were assigned from the
+    corresponding component of expr using pointer assignment (7.2.2) for
+    each pointer component, defined assignment for each nonpointer
+    nonallocatable component of a type that has a type-bound defined
+    assignment consistent with the component, intrinsic assignment for
+    each other nonpointer nonallocatable component, ..." 
+ 
+    The pointer assignments are taken care of by the intrinsic
+    assignment of the structure itself.  This function recursively adds
+    defined assignments where required.  */
+ 
+ static void
+ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
+ {
+   gfc_component *comp1, *comp2;
+   gfc_code *this_code, *next, *root, *previous;
+ 
+   /* Filter out continuing processing after an error.  */
+   if ((*code)->expr1->ts.type != BT_DERIVED
+       || (*code)->expr2->ts.type != BT_DERIVED)
+     return;
+ 
+   comp1 = (*code)->expr1->ts.u.derived->components;
+   comp2 = (*code)->expr2->ts.u.derived->components;
+ 
+   for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
+     {
+       if (comp1->ts.type != BT_DERIVED
+ 	  || comp1->ts.u.derived == NULL
+ 	  || (comp1->attr.pointer || comp1->attr.allocatable)
+ 	  || (*code)->expr1->ts.u.derived == comp1->ts.u.derived)
+ 	continue;
+ 
+       /* Make an assigment for this component.  */
+       this_code = gfc_get_code ();
+       this_code->op = EXEC_ASSIGN;
+       this_code->next = NULL;
+       this_code->expr1 = gfc_copy_expr ((*code)->expr1);
+       this_code->expr2 = gfc_copy_expr ((*code)->expr2);
+ 
+       add_comp_ref (this_code->expr1, comp1);
+       add_comp_ref (this_code->expr2, comp2);
+ 
+       root = this_code;
+ 
+       /* Convert the assignment if there is a defined assignment for
+ 	 this type.  Otherwise, recurse into its components.  */
+       if (resolve_ordinary_assign (this_code, ns)
+ 	  && this_code->op == EXEC_COMPCALL)
+ 	resolve_typebound_subroutine (this_code);
+       else if (this_code && this_code->op == EXEC_ASSIGN)
+ 	generate_component_assignments (&this_code, ns);
+ 
+       previous = NULL;
+       this_code = root;
+ 
+       /* Go through the code chain eliminating all but calls to
+ 	 typebound procedures. Since we have been through
+ 	 resolve_typebound_subroutine. */
+       for (; this_code; this_code = this_code->next)
+ 	{
+ 	  if (this_code->op == EXEC_ASSIGN_CALL)
+ 	    {
+ 	      gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym;
+ 	      /* Check that there is a defined assignment.  If so, then
+ 	         resolve the call.  */
+ 	      if (fsym->ts.type == BT_CLASS
+ 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
+ 		  && CLASS_DATA (fsym)->ts.u.derived->f2k_derived
+ 			->tb_op[INTRINSIC_ASSIGN])
+ 		{
+ 		  resolve_call (this_code);
+ 		  goto next;
+ 		}
+ 	    }
+ 
+ 	  next = this_code->next;
+ 	  if (this_code == root)
+ 	    root = next;
+ 	  else
+ 	    previous->next = next;
+ 
+ 	  next = this_code;
+ 	  next->next = NULL;
+ 	  gfc_free_statements (next);
+ 	next:
+ 	  previous = this_code;
+ 	}
+ 
+       /* Now attach the remaining code chain to the input code. Step on
+ 	 to the end of the new code since resolution is complete.  */
+       if (root)
+ 	{
+ 	  next = (*code)->next;
+ 	  (*code)->next = root;
+ 	  for (;root; root = root->next)
+ 	    if (!root->next)
+ 	      break;
+ 	  root->next = next;
+ 	  *code = root;
+ 	}
+    }
+ }
+ 
+ 
  /* Given a block of code, recursively resolve everything pointed to by this
     code block.  */
  
*************** resolve_code (gfc_code *code, gfc_namesp
*** 9647,9652 ****
--- 9771,9781 ----
  	      else
  		goto call;
  	    }
+ 
+ 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
+ 	  if (code->expr1->ts.type == BT_DERIVED)
+ 	    generate_component_assignments (&code, ns);
+ 
  	  break;
  
  	case EXEC_LABEL_ASSIGN:
Index: gcc/testsuite/gfortran.dg/defined_assignment_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/defined_assignment_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/defined_assignment_1.f90	(revision 0)
***************
*** 0 ****
--- 1,90 ----
+ ! { dg-do run }
+ ! Test the fix for PR46897.
+ !
+ ! Contributed by Rouson Damian <rouson@sandia.gov>
+ !
+ module m0
+   implicit none
+   type component
+     integer :: i
+   contains
+     procedure :: assign0
+     generic :: assignment(=)=>assign0
+   end type
+   type parent
+     type(component) :: foo
+   end type
+   type, extends(parent) :: child
+     integer :: j
+   end type
+ contains
+   subroutine assign0(lhs,rhs)
+     class(component), intent(out) :: lhs
+     class(component), intent(in) :: rhs
+     lhs%i = 20
+   end subroutine 
+   type(child) function new_child()
+   end function
+ end module 
+ 
+ module m1
+   implicit none
+   type component
+     integer :: i
+   contains
+     procedure :: assign1
+     generic :: assignment(=)=>assign1
+   end type
+   type t
+     type(component) :: foo
+   end type
+ contains
+   subroutine assign1(lhs,rhs)
+     class(component), intent(out) :: lhs
+     class(component), intent(in) :: rhs
+     lhs%i = 21
+   end subroutine
+ end module
+ 
+ module m2
+   implicit none
+   type component2
+     integer :: i = 2
+   end type
+   interface assignment(=)
+     module procedure assign2
+   end interface
+   type t2
+     type(component2) :: foo
+   end type
+ contains
+   subroutine assign2(lhs,rhs)
+     type(component2), intent(out) :: lhs
+     type(component2), intent(in) :: rhs
+     lhs%i = 22
+   end subroutine
+ end module 
+ 
+ program main
+   use m0
+   use m1
+   use m2
+   implicit none
+   type(child) :: infant0
+   type(t) :: infant1, newchild1
+   type(t2) :: infant2, newchild2
+ 
+ ! Test the reported problem.
+   infant0 = new_child()
+   if (infant0%parent%foo%i .ne. 20) call abort
+ 
+ ! Test the case of comment #1 of the PR.
+   infant1 = newchild1
+   if (infant1%foo%i .ne. 21) call abort
+ 
+ ! Test the case of comment #2 of the PR.
+   infant2 = newchild2
+   if (infant2%foo%i .ne. 2) call abort
+ end
+ 
+