From 139d4065e80d9141a23cf84d8b31fc9ee7c5d8c3 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Sun, 5 Feb 2017 16:43:03 +0100 Subject: [PATCH] re PR fortran/79344 (segmentation faults and run-time errors) gcc/fortran/ChangeLog: 2017-02-05 Andre Vehreschild PR fortran/79344 * trans-stmt.c (gfc_trans_allocate): Only deallocate the components of the temporary, when a new object was created for the temporary. Not when it is just an alias to an existing object. gcc/testsuite/ChangeLog: 2017-02-04 Andre Vehreschild PR fortran/79344 * gfortran.dg/allocate_with_source_24.f90: New test. From-SVN: r245194 --- gcc/fortran/ChangeLog | 7 + gcc/fortran/trans-stmt.c | 12 +- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/allocate_with_source_24.f90 | 134 ++++++++++++++++++ 4 files changed, 153 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_with_source_24.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 222e91f15bb..400f516203e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2017-02-05 Andre Vehreschild + + PR fortran/79344 + * trans-stmt.c (gfc_trans_allocate): Only deallocate the components of + the temporary, when a new object was created for the temporary. Not + when it is just an alias to an existing object. + 2017-02-05 Andre Vehreschild PR fortran/79335 diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 61e597f6a1f..773ca704f38 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5572,7 +5572,8 @@ gfc_trans_allocate (gfc_code * code) expression. */ if (code->expr3) { - bool vtab_needed = false, temp_var_needed = false; + bool vtab_needed = false, temp_var_needed = false, + temp_obj_created = false; is_coarray = gfc_is_coarray (code->expr3); @@ -5645,7 +5646,7 @@ gfc_trans_allocate (gfc_code * code) code->expr3->ts, false, true, false, false); - temp_var_needed = !VAR_P (se.expr); + temp_obj_created = temp_var_needed = !VAR_P (se.expr); } gfc_add_block_to_block (&block, &se.pre); gfc_add_block_to_block (&post, &se.post); @@ -5714,11 +5715,12 @@ gfc_trans_allocate (gfc_code * code) } /* Deallocate any allocatable components in expressions that use a - temporary, i.e. are not of expr-type EXPR_VARIABLE or force the - use of a temporary, after the assignment of expr3 is completed. */ + temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. + E.g. temporaries of a function call need freeing of their components + here. */ if ((code->expr3->ts.type == BT_DERIVED || code->expr3->ts.type == BT_CLASS) - && (code->expr3->expr_type != EXPR_VARIABLE || temp_var_needed) + && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) && code->expr3->ts.u.derived->attr.alloc_comp) { tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index af60081ba0b..898f55a44a3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-02-05 Andre Vehreschild + + PR fortran/79344 + * gfortran.dg/allocate_with_source_24.f90: New test. + 2017-02-05 Andre Vehreschild PR fortran/79230 diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_24.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_24.f90 new file mode 100644 index 00000000000..ec11d7af401 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_24.f90 @@ -0,0 +1,134 @@ +! { dg-do run } +! +! Test that the temporary in a sourced-ALLOCATE is not freeed. +! PR fortran/79344 +! Contributed by Juergen Reuter + +module iso_varying_string + implicit none + + type, public :: varying_string + private + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + + interface assignment(=) + module procedure op_assign_VS_CH + end interface assignment(=) + + interface operator(/=) + module procedure op_not_equal_VS_CA + end interface operator(/=) + + interface len + module procedure len_ + end interface len + + interface var_str + module procedure var_str_ + end interface var_str + + public :: assignment(=) + public :: operator(/=) + public :: len + + private :: op_assign_VS_CH + private :: op_not_equal_VS_CA + private :: char_auto + private :: len_ + private :: var_str_ + +contains + + elemental function len_ (string) result (length) + type(varying_string), intent(in) :: string + integer :: length + if(ALLOCATED(string%chars)) then + length = SIZE(string%chars) + else + length = 0 + endif + end function len_ + + elemental subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + var = var_str(exp) + end subroutine op_assign_VS_CH + + pure function op_not_equal_VS_CA (var, exp) result(res) + type(varying_string), intent(in) :: var + character(LEN=*), intent(in) :: exp + logical :: res + integer :: i + res = .true. + if (len(exp) /= size(var%chars)) return + do i = 1, size(var%chars) + if (var%chars(i) /= exp(i:i)) return + end do + res = .false. + end function op_not_equal_VS_CA + + pure function char_auto (string) result (char_string) + type(varying_string), intent(in) :: string + character(LEN=len(string)) :: char_string + integer :: i_char + forall(i_char = 1:len(string)) + char_string(i_char:i_char) = string%chars(i_char) + end forall + end function char_auto + + elemental function var_str_ (char) result (string) + character(LEN=*), intent(in) :: char + type(varying_string) :: string + integer :: length + integer :: i_char + length = LEN(char) + ALLOCATE(string%chars(length)) + forall(i_char = 1:length) + string%chars(i_char) = char(i_char:i_char) + end forall + end function var_str_ + +end module iso_varying_string + +!!!!! + +program test_pr79344 + + use iso_varying_string, string_t => varying_string + + implicit none + + type :: field_data_t + type(string_t), dimension(:), allocatable :: name + end type field_data_t + + type(field_data_t) :: model, model2 + allocate(model%name(2)) + model%name(1) = "foo" + model%name(2) = "bar" + call copy(model, model2) +contains + + subroutine copy(prt, prt_src) + implicit none + type(field_data_t), intent(inout) :: prt + type(field_data_t), intent(in) :: prt_src + integer :: i + if (allocated (prt_src%name)) then + if (prt_src%name(1) /= "foo") call abort() + if (prt_src%name(2) /= "bar") call abort() + + if (allocated (prt%name)) deallocate (prt%name) + allocate (prt%name (size (prt_src%name)), source = prt_src%name) + ! The issue was, that prt_src was empty after sourced-allocate. + if (prt_src%name(1) /= "foo") call abort() + if (prt_src%name(2) /= "bar") call abort() + if (prt%name(1) /= "foo") call abort() + if (prt%name(2) /= "bar") call abort() + end if + end subroutine copy + +end program test_pr79344 + -- 2.30.2