re PR fortran/39879 (double free or corruption abort with gfortran)
2009-04-28 Paul Thomas <pault@gcc.gnu.org> PR fortran/39879 * trans_expr.c (gfc_conv_procedure_call): Deep copy a derived type parentheses argument if it is a variable with allocatable components. 2009-04-28 Paul Thomas <pault@gcc.gnu.org> PR fortran/39879 * gfortran.dg/alloc_comp_assign_10.f90: New test. From-SVN: r146871
This commit is contained in:
parent
b2ed71b61a
commit
7d44f53181
|
@ -1,3 +1,10 @@
|
|||
2009-04-28 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/39879
|
||||
* trans_expr.c (gfc_conv_procedure_call): Deep copy a derived
|
||||
type parentheses argument if it is a variable with allocatable
|
||||
components.
|
||||
|
||||
2009-04-27 Ian Lance Taylor <iant@google.com>
|
||||
|
||||
* trans-intrinsic.c (DEFINE_MATH_BUILTIN): Add casts to enum
|
||||
|
|
|
@ -1119,7 +1119,8 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
|
|||
gfc_add_modify (&se->pre, var, tmp);
|
||||
|
||||
/* Free the temporary afterwards. */
|
||||
tmp = gfc_call_free (convert (pvoid_type_node, var));
|
||||
tmp = gfc_call_free (var, true, &gfc_current_locus,
|
||||
ALLOCTYPE_TEMPORARY);
|
||||
gfc_add_expr_to_block (&se->post, tmp);
|
||||
}
|
||||
|
||||
|
@ -2782,7 +2783,18 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
|
|||
break;
|
||||
}
|
||||
|
||||
if (e->expr_type == EXPR_OP
|
||||
&& e->value.op.op == INTRINSIC_PARENTHESES
|
||||
&& e->value.op.op1->expr_type == EXPR_VARIABLE)
|
||||
{
|
||||
tree local_tmp;
|
||||
local_tmp = gfc_evaluate_now (tmp, &se->pre);
|
||||
local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
|
||||
gfc_add_expr_to_block (&se->post, local_tmp);
|
||||
}
|
||||
|
||||
tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
|
||||
|
||||
gfc_add_expr_to_block (&se->post, tmp);
|
||||
}
|
||||
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2009-04-28 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/39879
|
||||
* gfortran.dg/alloc_comp_assign_10.f90: New test.
|
||||
|
||||
2009-04-28 Ben Elliston <bje@au.ibm.com>
|
||||
|
||||
PR c++/35652
|
||||
|
|
|
@ -0,0 +1,61 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Test the fix for PR39879, in which gfc gagged on the double
|
||||
! defined assignment where the rhs had a default initialiser.
|
||||
!
|
||||
! Contributed by David Sagan <david.sagan@gmail.com>
|
||||
!
|
||||
module test_struct
|
||||
interface assignment (=)
|
||||
module procedure tao_lat_equal_tao_lat
|
||||
end interface
|
||||
type bunch_params_struct
|
||||
integer n_live_particle
|
||||
end type
|
||||
type tao_lattice_struct
|
||||
type (bunch_params_struct), allocatable :: bunch_params(:)
|
||||
type (bunch_params_struct), allocatable :: bunch_params2(:)
|
||||
end type
|
||||
type tao_universe_struct
|
||||
type (tao_lattice_struct), pointer :: model, design
|
||||
character(200), pointer :: descrip => NULL()
|
||||
end type
|
||||
type tao_super_universe_struct
|
||||
type (tao_universe_struct), allocatable :: u(:)
|
||||
end type
|
||||
type (tao_super_universe_struct), save, target :: s
|
||||
contains
|
||||
subroutine tao_lat_equal_tao_lat (lat1, lat2)
|
||||
implicit none
|
||||
type (tao_lattice_struct), intent(inout) :: lat1
|
||||
type (tao_lattice_struct), intent(in) :: lat2
|
||||
if (allocated(lat2%bunch_params)) then
|
||||
lat1%bunch_params = lat2%bunch_params
|
||||
end if
|
||||
if (allocated(lat2%bunch_params2)) then
|
||||
lat1%bunch_params2 = lat2%bunch_params2
|
||||
end if
|
||||
end subroutine
|
||||
end module
|
||||
|
||||
program tao_program
|
||||
use test_struct
|
||||
implicit none
|
||||
type (tao_universe_struct), pointer :: u
|
||||
integer n, i
|
||||
allocate (s%u(1))
|
||||
u => s%u(1)
|
||||
allocate (u%design, u%model)
|
||||
n = 112
|
||||
allocate (u%model%bunch_params(0:n), u%design%bunch_params(0:n))
|
||||
u%design%bunch_params%n_live_particle = [(i, i = 0, n)]
|
||||
u%model = u%design
|
||||
u%model = u%design ! The double assignment was the cause of the ICE
|
||||
if (.not. allocated (u%model%bunch_params)) call abort
|
||||
if (any (u%model%bunch_params%n_live_particle .ne. [(i, i = 0, n)])) call abort
|
||||
Deallocate (u%model%bunch_params, u%design%bunch_params)
|
||||
deallocate (u%design, u%model)
|
||||
deallocate (s%u)
|
||||
end program
|
||||
|
||||
! { dg-final { cleanup-modules "test_struct" } }
|
Loading…
Reference in New Issue