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 <pa...@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 <pa...@gcc.gnu.org>
PR fortran/51634
* gfortran.dg/typebound_operator_12.f03: New.
* gfortran.dg/typebound_operator_13.f03: New.
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 <bur...@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 <bur...@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" } }
+
