===================================================================
*************** gfc_conv_procedure_call (gfc_se * se, gf
/* 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))
/* 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
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);
===================================================================
***************
+ ! { 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" } }
+
===================================================================
***************
+ ! { 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" } }
+