From 7d44f531817fdd9165fbbbdf579225164aa8ae51 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 28 Apr 2009 05:16:19 +0000 Subject: [PATCH] re PR fortran/39879 (double free or corruption abort with gfortran) 2009-04-28 Paul Thomas 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 PR fortran/39879 * gfortran.dg/alloc_comp_assign_10.f90: New test. From-SVN: r146871 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/trans-expr.c | 14 ++++- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/alloc_comp_assign_10.f90 | 61 +++++++++++++++++++ 4 files changed, 86 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_assign_10.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a7abbc88c5d..2ca02710870 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2009-04-28 Paul Thomas + + 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 * trans-intrinsic.c (DEFINE_MATH_BUILTIN): Add casts to enum diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 2b67c6ddcd3..77a2dfae356 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 777922bcbea..53a81259cfb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-04-28 Paul Thomas + + PR fortran/39879 + * gfortran.dg/alloc_comp_assign_10.f90: New test. + 2009-04-28 Ben Elliston PR c++/35652 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_assign_10.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_assign_10.f90 new file mode 100644 index 00000000000..c85edea62fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_assign_10.f90 @@ -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 +! +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" } } -- 2.30.2