Re: [PATCH, Fortran, pr79344, v1] [7 Regression] segmentation faults and run-time errors

[Andre Vehreschild]

Hi Mikael,

thanks for the fast review. Committed as r245193.

Regards,
Andre

On Sun, 5 Feb 2017 15:32:25 +0100
Mikael Morin  wrote:

> Le 04/02/2017 à 19:43, Andre Vehreschild a écrit :
> > Hi all,
> >
> > attached patch fixes the issue of losing the data in the SOURCE= expression
> > of an ALLOCATE() when the source-expression is just a simple variable. The
> > issue was that internally a temporary variable was created, whose
> > components were freed afterwards. Now the components are only freed on
> > temporary objects, i.e., when the source-expression is not an
> > EXPR_VARIABLE, e.g. an EXPR_STRUCTURE or EXPR_FUNCTION.
> >
> > Bootstraps and regtests ok on x86_64-linux/f25. Ok for trunk?
> >  
> Hello,
> 
> this looks good to me.
> Thanks
> 
> Mikael
> 


-- 
Andre Vehreschild * Email: vehre ad gmx dot de 
Index: gcc/testsuite/ChangeLog
===
--- gcc/testsuite/ChangeLog	(Revision 245193)
+++ gcc/testsuite/ChangeLog	(Arbeitskopie)
@@ -1,5 +1,10 @@
 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
 	* gfortran.dg/der_ptr_component_2.f90: New test.
 
Index: gcc/testsuite/gfortran.dg/allocate_with_source_24.f90
===
--- gcc/testsuite/gfortran.dg/allocate_with_source_24.f90	(nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_24.f90	(Revision 245194)
@@ -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 

Re: [PATCH, Fortran, pr79344, v1] [7 Regression] segmentation faults and run-time errors

[Mikael Morin]

Le 04/02/2017 à 19:43, Andre Vehreschild a écrit :

Hi all,

attached patch fixes the issue of losing the data in the SOURCE= expression of
an ALLOCATE() when the source-expression is just a simple variable. The issue
was that internally a temporary variable was created, whose components were
freed afterwards. Now the components are only freed on temporary objects, i.e.,
when the source-expression is not an EXPR_VARIABLE, e.g. an EXPR_STRUCTURE or
EXPR_FUNCTION.

Bootstraps and regtests ok on x86_64-linux/f25. Ok for trunk?


Hello,

this looks good to me.
Thanks

Mikael

[PATCH, Fortran, pr79344, v1] [7 Regression] segmentation faults and run-time errors

[Andre Vehreschild]

Hi all,

attached patch fixes the issue of losing the data in the SOURCE= expression of
an ALLOCATE() when the source-expression is just a simple variable. The issue
was that internally a temporary variable was created, whose components were
freed afterwards. Now the components are only freed on temporary objects, i.e.,
when the source-expression is not an EXPR_VARIABLE, e.g. an EXPR_STRUCTURE or
EXPR_FUNCTION.

Bootstraps and regtests ok on x86_64-linux/f25. Ok for trunk?

Regards,
Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 
gcc/fortran/ChangeLog:

2017-02-04  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  

* gfortran.dg/allocate_with_source_24.f90: New test.


diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 61e597f..773ca70 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 (, );
   gfc_add_block_to_block (, );
@@ -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/gfortran.dg/allocate_with_source_24.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_24.f90
new file mode 100644
index 000..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)
+