re PR fortran/51634 ([OOP] ICE with polymorphic operators)

2012-01-18  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-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51634
	* gfortran.dg/typebound_operator_12.f03: New.
	* gfortran.dg/typebound_operator_13.f03: New.

From-SVN: r183287

gcc/fortran/ChangeLog

@@ -1,3 +1,9 @@
+2012-01-18  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  Tobias Burnus  <burnus@net-b.de>
 	    Janne Blomqvist  <jb@gcc.gnu.org>
 

gcc/fortran/trans-expr.c

@@ -3736,7 +3736,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       /* 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
+      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))
@@ -3768,6 +3768,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      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);

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2012-01-18  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/51634
+	* gfortran.dg/typebound_operator_12.f03: New.
+	* gfortran.dg/typebound_operator_13.f03: New.
+
 2012-01-18  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/51225

gcc/testsuite/gfortran.dg/typebound_operator_12.f03

@@ -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" } }
+

gcc/testsuite/gfortran.dg/typebound_operator_13.f03

@@ -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" } }
+