re PR fortran/79344 (segmentation faults and run-time errors)

gcc/fortran/ChangeLog:

2017-02-05  Andre Vehreschild  <vehre@gcc.gnu.org>

	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  <vehre@gcc.gnu.org>

	PR fortran/79344
	* gfortran.dg/allocate_with_source_24.f90: New test.

From-SVN: r245194

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 222e91f15bb996b47ac2354fd66a3bff25f207f1..400f516203ee5721c91c0be5f7ad327bf18d681c 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2017-02-05  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       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  <vehre@gcc.gnu.org>
 
        PR fortran/79335

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 61e597f6a1f974f273f96f88325d16e0264f751b..773ca704f387cdc02bd978f834719f94bf6e65b8 100644 (file)
--- 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 af60081ba0b711c22ed8a4fbe5a153c3066b3769..898f55a44a3dec9f0d28953b97ee788e736d699b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2017-02-05  Andre Vehreschild  <vehre@gcc.gnu.org>
+
+       PR fortran/79344
+       * gfortran.dg/allocate_with_source_24.f90: New test.
+
 2017-02-05  Andre Vehreschild  <vehre@gcc.gnu.org>
 
        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 (file)
index 0000000..ec11d7a
--- /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
+