I have committed the attached patch as obvious. The problem was: If the
allocate object had allocatable components, one set all those to zero.
Otherwise for polymorphic types one sets the whole allocated memory to zero.
If now the declared type had allocatable components but the effective
type added more such components, the latter never got nullified.
Solution: Checking the type BT_DERIVED on the allocate object
("al->expr") and not on "expr". The latter is "al->expr->_data" and thus
always BT_CLASS.
Build, regtested and committed (Rev. 183667) on x86-64-linux
NOTE: This patch does not solve all issues of the PR as there is also a
bug in _copy, which does only an incomplete deep copy. For details and a
possible solution see PR.
Tobias
2012-01-28 Tobias Burnus <bur...@net-b.de>
PR fortran/51972
* trans-stmt.c (gfc_trans_allocate): Properly check whether
we have a BT_CLASS which needs to be memset.
2012-01-28 Tobias Burnus <bur...@net-b.de>
PR fortran/51972
* gfortran.dg/class_allocate_12.f90: New.
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 183667)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -4950,7 +4950,8 @@ gfc_trans_allocate (gfc_code * code)
else
gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
- if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+ if (al->expr->ts.type == BT_DERIVED
+ && expr->ts.u.derived->attr.alloc_comp)
{
tmp = build_fold_indirect_ref_loc (input_location, se.expr);
tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
Index: gcc/testsuite/gfortran.dg/class_allocate_12.f90
===================================================================
--- gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/class_allocate_12.f90 (Arbeitskopie)
@@ -0,0 +1,97 @@
+! { dg-do run }
+!
+! PR fortran/51972
+!
+! Contributed by Damian Rouson
+!
+! TODO: Remove the STOP line below after fixing
+! The remaining issue of the PR
+!
+
+module surrogate_module
+ type ,abstract :: surrogate
+ end type
+end module
+
+module strategy_module
+ use surrogate_module
+
+ type :: strategy
+ end type
+end module
+
+module integrand_module
+ use surrogate_module
+ use strategy_module
+ implicit none
+
+ type ,abstract, extends(surrogate) :: integrand
+ class(strategy), allocatable :: quadrature
+ end type
+end module integrand_module
+
+module lorenz_module
+ use strategy_module
+ use integrand_module
+ implicit none
+
+ type ,extends(integrand) :: lorenz
+ real, dimension(:), allocatable :: state
+ contains
+ procedure ,public :: assign => assign_lorenz
+ end type
+contains
+ type(lorenz) function constructor(initial_state, this_strategy)
+ real ,dimension(:) ,intent(in) :: initial_state
+ class(strategy) ,intent(in) :: this_strategy
+ constructor%state=initial_state
+ allocate (constructor%quadrature, source=this_strategy)
+ end function
+
+ subroutine assign_lorenz(lhs,rhs)
+ class(lorenz) ,intent(inout) :: lhs
+ class(integrand) ,intent(in) :: rhs
+ select type(rhs)
+ class is (lorenz)
+ allocate (lhs%quadrature, source=rhs%quadrature)
+ lhs%state=rhs%state
+ end select
+ end subroutine
+end module lorenz_module
+
+module runge_kutta_2nd_module
+ use surrogate_module,only : surrogate
+ use strategy_module ,only : strategy
+ use integrand_module,only : integrand
+ implicit none
+
+ type, extends(strategy) ,public :: runge_kutta_2nd
+ contains
+ procedure, nopass :: integrate
+ end type
+contains
+ subroutine integrate(this)
+ class(surrogate) ,intent(inout) :: this
+ class(integrand) ,allocatable :: this_half
+
+ select type (this)
+ class is (integrand)
+ allocate (this_half, source=this)
+ end select
+ STOP 'SUCESS!' ! See TODO above
+ end subroutine
+end module
+
+program main
+ use lorenz_module
+ use runge_kutta_2nd_module ,only : runge_kutta_2nd, integrate
+ implicit none
+
+ type(runge_kutta_2nd) :: timed_lorenz_integrator
+ type(lorenz) :: attractor
+
+ attractor = constructor( [1., 1., 1.] , timed_lorenz_integrator)
+ call integrate(attractor)
+end program main
+
+! { dg-final { cleanup-modules "surrogate_module strategy_module integrand_module runge_kutta_2nd_module" } }
