Patchwork [fortran] PR51634 - [OOP] ICE with polymorphic operators

login
register
mail settings
Submitter Paul Richard Thomas
Date Jan. 17, 2012, 12:25 p.m.
Message ID <CAGkQGiLNJcU=OYZ6OXapfdKEG14BUS3tCk6Hnj2UjiTJvR64Rg@mail.gmail.com>
Download mbox | patch
Permalink /patch/136455/
State New
Headers show

Comments

Paul Richard Thomas - Jan. 17, 2012, 12:25 p.m.
Dear All,

The attached is self-explanatory and fixes the last wrinkles with
PR51634. In addition, the patch incorporates the requirements of class
expressions being used throughout, as reflected in the second
testcase.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk.

Cheers

Paul

2012-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51634
	* trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
	components of temporary class arguments.

2012-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51634
	* gfortran.dg/typebound_operator_12.f03: New.
	* gfortran.dg/typebound_operator_13.f03: New.
Tobias Burnus - Jan. 17, 2012, 1:12 p.m.
On 01/17/2012 01:25 PM, Paul Richard Thomas wrote:
> The attached is self-explanatory and fixes the last wrinkles with
> PR51634. In addition, the patch incorporates the requirements of class
> expressions being used throughout, as reflected in the second
> testcase.
>
> Bootstrapped and regtested on FC9/x86_64 - OK for trunk.

OK. Thanks for the patch!

Tobias

> 2012-01-17  Paul Thomas<pault@gcc.gnu.org>
>
> 	PR fortran/51634
> 	* trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
> 	components of temporary class arguments.
>
> 2012-01-17  Paul Thomas<pault@gcc.gnu.org>
>
> 	PR fortran/51634
> 	* gfortran.dg/typebound_operator_12.f03: New.
> 	* gfortran.dg/typebound_operator_13.f03: New.
Paul Richard Thomas - Jan. 18, 2012, 8:54 p.m.
Dear Tobias,

Committed as r183287.  Thanks for the review.

Paul

>> 2012-01-17  Paul Thomas<pault@gcc.gnu.org>
>>
>>        PR fortran/51634
>>        * trans-expr.c (gfc_conv_procedure_call): Deallocate allocatable
>>        components of temporary class arguments.
>>
>> 2012-01-17  Paul Thomas<pault@gcc.gnu.org>
>>
>>        PR fortran/51634
>>        * gfortran.dg/typebound_operator_12.f03: New.
>>        * gfortran.dg/typebound_operator_13.f03: New.
>
>

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 183125)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3736,3742 ****
        /* Allocated allocatable components of derived types must be
  	 deallocated for non-variable scalars.  Non-variable arrays are
  	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
!       if (e && e->ts.type == BT_DERIVED
  	    && e->ts.u.derived->attr.alloc_comp
  	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
  	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
--- 3736,3742 ----
        /* Allocated allocatable components of derived types must be
  	 deallocated for non-variable scalars.  Non-variable arrays are
  	 dealt with in trans-array.c(gfc_conv_array_parameter).  */
!       if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
  	    && e->ts.u.derived->attr.alloc_comp
  	    && !(e->symtree && e->symtree->n.sym->attr.pointer)
  	    && (e->expr_type != EXPR_VARIABLE && !e->rank))
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3768,3773 ****
--- 3768,3783 ----
  	      gfc_add_expr_to_block (&se->post, local_tmp);
  	    }
  
+ 	  if (e->ts.type == BT_DERIVED && fsym && fsym->ts.type == BT_CLASS)
+ 	    {
+ 	      /* The derived type is passed to gfc_deallocate_alloc_comp.
+ 		 Therefore, class actuals can handled correctly but derived
+ 		 types passed to class formals need the _data component.  */
+ 	      tmp = gfc_class_data_get (tmp);
+ 	      if (!CLASS_DATA (fsym)->attr.dimension)
+ 		tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ 	    }
+ 
  	  tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
  
  	  gfc_add_expr_to_block (&se->post, tmp);
Index: gcc/testsuite/gfortran.dg/typebound_operator_12.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_12.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/typebound_operator_12.f03	(revision 0)
***************
*** 0 ****
--- 1,45 ----
+ ! { dg-do run }
+ ! PR51634 - Handle allocatable components correctly in expressions 
+ ! involving typebound operators. See comment 2 of PR.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ ! 
+ module soop_stars_class
+   implicit none
+   type soop_stars
+     real, dimension(:), allocatable :: position,velocity
+   contains
+     procedure :: total
+     procedure :: product
+     generic :: operator(+) => total
+     generic :: operator(*) => product
+   end type
+ contains
+   type(soop_stars) function product(lhs,rhs)
+     class(soop_stars) ,intent(in) :: lhs
+     real ,intent(in) :: rhs
+     product%position = lhs%position*rhs
+     product%velocity = lhs%velocity*rhs
+   end function
+ 
+   type(soop_stars) function total(lhs,rhs)
+     class(soop_stars) ,intent(in) :: lhs,rhs
+     total%position = lhs%position + rhs%position
+     total%velocity = lhs%velocity + rhs%velocity
+   end function
+ end module
+ 
+ program main
+   use soop_stars_class ,only : soop_stars
+   implicit none
+   type(soop_stars) :: fireworks
+   real :: dt
+   fireworks%position = [1,2,3]
+   fireworks%velocity = [4,5,6]
+   dt = 5
+   fireworks = fireworks + fireworks*dt
+   if (any (fireworks%position .ne. [6, 12, 18])) call abort
+   if (any (fireworks%velocity .ne. [24, 30, 36])) call abort
+ end program
+ ! { dg-final { cleanup-modules "soop_stars_class" } }
+ 
Index: gcc/testsuite/gfortran.dg/typebound_operator_13.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_13.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/typebound_operator_13.f03	(revision 0)
***************
*** 0 ****
--- 1,59 ----
+ ! { dg-do run }
+ ! PR51634 - Handle allocatable components correctly in expressions 
+ ! involving typebound operators. From comment 2 of PR but using
+ ! classes throughout.
+ !
+ ! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+ ! 
+ module soop_stars_class
+   implicit none
+   type soop_stars
+     real, dimension(:), allocatable :: position,velocity
+   contains
+     procedure :: total
+     procedure :: mult
+     procedure :: assign
+     generic :: operator(+) => total
+     generic :: operator(*) => mult
+     generic :: assignment(=) => assign
+   end type
+ contains
+   function mult(lhs,rhs)
+     class(soop_stars) ,intent(in) :: lhs
+     real ,intent(in) :: rhs
+     class(soop_stars), allocatable :: mult
+     type(soop_stars) :: tmp
+     tmp = soop_stars (lhs%position*rhs, lhs%velocity*rhs)
+     allocate (mult, source = tmp)
+   end function
+ 
+   function total(lhs,rhs)
+     class(soop_stars) ,intent(in) :: lhs,rhs
+     class(soop_stars), allocatable :: total
+     type(soop_stars) :: tmp
+     tmp = soop_stars (lhs%position + rhs%position, &
+                       lhs%velocity + rhs%velocity)
+     allocate (total, source = tmp)
+   end function
+ 
+   subroutine assign(lhs,rhs)
+     class(soop_stars), intent(in) :: rhs
+     class(soop_stars), intent(out) :: lhs
+     lhs%position = rhs%position
+     lhs%velocity = rhs%velocity
+   end subroutine
+ end module
+ 
+ program main
+   use soop_stars_class ,only : soop_stars
+   implicit none
+   class(soop_stars), allocatable :: fireworks
+   real :: dt
+   allocate (fireworks, source = soop_stars ([1,2,3], [4,5,6]))
+   dt = 5
+   fireworks = fireworks + fireworks*dt
+   if (any (fireworks%position .ne. [6, 12, 18])) call abort
+   if (any (fireworks%velocity .ne. [24, 30, 36])) call abort
+ end program
+ ! { dg-final { cleanup-modules "soop_stars_class" } }
+