re PR fortran/66079 (memory leak with source allocation in internal subprogram)

2015-06-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/66079
	* trans-expr.c (gfc_conv_procedure_call): Allocatable scalar
	function results must be freed and nullified after use. Create
	a temporary to hold the result to prevent duplicate calls.
	* trans-stmt.c (gfc_trans_allocate): Rename temporary variable
	as 'source'. Deallocate allocatable components of non-variable
	'source's.

2015-06-11  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/66079
	* gfortran.dg/allocatable_scalar_13.f90: New test

From-SVN: r224383

5 files changed, 115 insertions, 3 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 57a9997..662e3d2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2015-06-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/66079
+	* trans-expr.c (gfc_conv_procedure_call): Allocatable scalar
+	function results must be freed and nullified after use. Create
+	a temporary to hold the result to prevent duplicate calls.
+	* trans-stmt.c (gfc_trans_allocate): Rename temporary variable
+	as 'source'. Deallocate allocatable components of non-variable
+	'source's.
+
 2015-06-11  Pierre-Marie de Rodat  <derodat@adacore.com>
 
 	* f95-lang.c (gfc_create_decls): Register the main translation unit
@@ -258,7 +268,7 @@
 
 	PR fortran/66044
 	* decl.c(gfc_match_entry):  Change a gfc_internal_error() into
-	a gfc_error() 
+	a gfc_error()
 
 2015-05-18  Steven G. Kargl  <kargl@gcc.gnu.org>
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c880bc..e3f49f5 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5871,6 +5871,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   fntype = TREE_TYPE (TREE_TYPE (se->expr));
   se->expr = build_call_vec (TREE_TYPE (fntype), se->expr, arglist);
 
+  /* Allocatable scalar function results must be freed and nullified
+     after use. This necessitates the creation of a temporary to
+     hold the result to prevent duplicate calls.  */
+  if (!byref && sym->ts.type != BT_CHARACTER
+      && sym->attr.allocatable && !sym->attr.dimension)
+    {
+      tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+      gfc_add_modify (&se->pre, tmp, se->expr);
+      se->expr = tmp;
+      tmp = gfc_call_free (tmp);
+      gfc_add_expr_to_block (&post, tmp);
+      gfc_add_modify (&post, se->expr, build_int_cst (TREE_TYPE (se->expr), 0));
+    }
+
   /* If we have a pointer function, but we don't want a pointer, e.g.
      something like
         x = f()
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a7f39d0..69750df 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5207,6 +5207,7 @@ gfc_trans_allocate (gfc_code * code)
 				     false, false);
 	  gfc_add_block_to_block (&block, &se.pre);
 	  gfc_add_block_to_block (&post, &se.post);
+
 	  /* Prevent aliasing, i.e., se.expr may be already a
 		 variable declaration.  */
 	  if (!VAR_P (se.expr))
@@ -5216,8 +5217,20 @@ gfc_trans_allocate (gfc_code * code)
 						 se.expr);
 	      /* We need a regular (non-UID) symbol here, therefore give a
 		 prefix.  */
-	      var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+	      var = gfc_create_var (TREE_TYPE (tmp), "source");
 	      gfc_add_modify_loc (input_location, &block, var, tmp);
+
+	      /* Deallocate any allocatable components after all the allocations
+		 and assignments of expr3 have been completed.  */
+	      if (code->expr3->ts.type == BT_DERIVED
+		  && code->expr3->rank == 0
+		  && code->expr3->ts.u.derived->attr.alloc_comp)
+		{
+		  tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+						   var, 0);
+		  gfc_add_expr_to_block (&post, tmp);
+		}
+
 	      tmp = var;
 	    }
 	  else
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f5abd3d..d46ba74 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2015-06-11  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/66079
+	* gfortran.dg/allocatable_scalar_13.f90: New test
+
 2015-06-11  Marek Polacek  <polacek@redhat.com>
 
 	* gcc.dg/fold-xor-3.c: New test.
@@ -666,7 +671,7 @@
 2015-05-27  Honggyu Kim  <hong.gyu.kim@lge.com>
 
 	PR target/65358
-	* gcc.dg/pr65358.c: New test. 
+	* gcc.dg/pr65358.c: New test.
 
 2015-05-27  Andre Vehreschild  <vehre@gmx.de>
 
diff --git a/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
new file mode 100644
index 0000000..bc6f017
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR66079. The original problem was with the first
+! allocate statement. The rest of this testcase fixes problems found
+! whilst working on it!
+!
+! Reported by Damian Rouson  <damian@sourceryinstitute.org>
+!
+  type subdata
+    integer, allocatable :: b
+  endtype
+!  block
+    call newRealVec
+!  end block
+contains
+  subroutine newRealVec
+    type(subdata), allocatable :: d, e, f
+    character(:), allocatable :: g, h, i
+    character(8), allocatable :: j
+    allocate(d,source=subdata(1)) ! memory was lost, now OK
+    allocate(e,source=d) ! OK
+    allocate(f,source=create (99)) ! memory was lost, now OK
+    if (d%b .ne. 1) call abort
+    if (e%b .ne. 1) call abort
+    if (f%b .ne. 99) call abort
+    allocate (g, source = greeting1("good day"))
+    if (g .ne. "good day") call abort
+    allocate (h, source = greeting2("hello"))
+    if (h .ne. "hello") call abort
+    allocate (i, source = greeting3("hiya!"))
+    if (i .ne. "hiya!") call abort
+    call greeting4 (j, "Goodbye ") ! Test that dummy arguments are OK
+    if (j .ne. "Goodbye ") call abort
+  end subroutine
+
+  function create (arg) result(res)
+    integer :: arg
+    type(subdata), allocatable :: res, res1
+    allocate(res, res1, source = subdata(arg))
+  end function
+
+  function greeting1 (arg) result(res) ! memory was lost, now OK
+    character(*) :: arg
+    Character(:), allocatable :: res
+    allocate(res, source = arg)
+  end function
+
+  function greeting2 (arg) result(res)
+    character(5) :: arg
+    Character(:), allocatable :: res
+    allocate(res, source = arg)
+  end function
+
+  function greeting3 (arg) result(res)
+    character(5) :: arg
+    Character(5), allocatable :: res, res1
+    allocate(res, res1, source = arg) ! Caused an ICE
+    if (res1 .ne. res) call abort
+  end function
+
+  subroutine greeting4 (res, arg)
+    character(8), intent(in) :: arg
+    Character(8), allocatable, intent(out) :: res
+    allocate(res, source = arg) ! Caused an ICE
+  end subroutine
+end
+! { dg-final { scan-tree-dump-times "builtin_malloc" 20 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } }
+