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
+
