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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 57a9997ad90bdb784a0ce97058bf11ee836ecd73..662e3d2f98a5f1bb8bdf0635c4ce6ba91a262c89 100644 (file)
--- 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 1c880bc8ccc058fcafdf54f4912c22309bc91f54..e3f49f597036cd73fed974a40a4495006fdaddc3 100644 (file)
--- 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 a7f39d0ad40b0282087753f9fa994ba8bdc4c1b8..69750dfa01030814a0f14e7893f5b892f8974a1a 100644 (file)
--- 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 f5abd3d4de752fb6f9f8ff06a3ee4365d7e2ffab..d46ba74e5001920ba8a5e4e5a8bd7c70fce90cd7 100644 (file)
--- 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 (file)
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" } }
+