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

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