Fortran: Fix regression on double free on elemental function [PR118747]

Fix a regression were adding a temporary variable inserted a copy of the
argument to the elemental function.  That copy was then later used to
free allocated memory, but the freeing was not tracked in the source
array correctly.

	PR fortran/118747

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_ctor_element): Remove copy to
	temporary variable.
	* trans-expr.cc (gfc_conv_procedure_call): Use references to
	array members instead of copies when freeing after use.
	Formatting fix.

gcc/testsuite/ChangeLog:

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8f76870b286ad2e528c8a3c5145edb47af83b9c2..6a00d26cb2f3a43dae05d384c90affa65f7b4ba9 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2002,13 +2002,10 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
 
   if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
       && expr->ts.u.derived->attr.alloc_comp)
-    {
-      if (!VAR_P (se->expr))
-       se->expr = gfc_evaluate_now (se->expr, &se->pre);
-      gfc_add_expr_to_block (&se->finalblock,
-                            gfc_deallocate_alloc_comp_no_caf (
-                              expr->ts.u.derived, se->expr, expr->rank, true));
-    }
+    gfc_add_expr_to_block (&se->finalblock,
+                          gfc_deallocate_alloc_comp_no_caf (expr->ts.u.derived,
+                                                            tmp, expr->rank,
+                                                            true));
 
   if (expr->ts.type == BT_CHARACTER)
     {

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index ab55940638e22c1f7e3fa1a42c33ae936dae403e..e619013f261ea16ea76f3e7e3e38c5ab63504a6f 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6999,6 +6999,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          if ((fsym && fsym->attr.value)
              || (ulim_copy && (argc == 2 || argc == 3)))
            gfc_conv_expr (&parmse, e);
+         else if (e->expr_type == EXPR_ARRAY)
+           {
+             gfc_conv_expr (&parmse, e);
+             if (e->ts.type != BT_CHARACTER)
+               parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+           }
          else
            gfc_conv_expr_reference (&parmse, e);
 
@@ -7930,11 +7936,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          /* It is known the e returns a structure type with at least one
             allocatable component.  When e is a function, ensure that the
             function is called once only by using a temporary variable.  */
-         if (!DECL_P (parmse.expr))
+         if (!DECL_P (parmse.expr) && e->expr_type == EXPR_FUNCTION)
            parmse.expr = gfc_evaluate_now_loc (input_location,
                                                parmse.expr, &se->pre);
 
-         if (fsym && fsym->attr.value)
+         if ((fsym && fsym->attr.value) || e->expr_type == EXPR_ARRAY)
            tmp = parmse.expr;
          else
            tmp = build_fold_indirect_ref_loc (input_location,
@@ -7993,7 +7999,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              /* Scalars passed to an assumed rank argument are converted to
                 a descriptor. Obtain the data field before deallocating any
                 allocatable components.  */
-             if (parm_rank == 0 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+             if (parm_rank == 0 && e->expr_type != EXPR_ARRAY
+                 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
                tmp = gfc_conv_descriptor_data_get (tmp);
 
              if (scalar_res_outside_loop)

diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_4.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_4.f90
new file mode 100644 (file)
index 0000000..06bd8b5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_4.f90
@@ -0,0 +1,27 @@
+!{ dg-do run }
+
+! Check freeing derived typed result's allocatable components is not done twice.
+! Contributed by Damian Rouson  <damian@archaeologic.codes>
+
+program pr118747
+  implicit none
+
+  type string_t
+    character(len=:), allocatable :: string_
+  end type
+
+  call check_allocation([foo(), foo()])
+
+contains
+
+  type(string_t) function foo()
+    foo%string_ = "foo"
+  end function
+
+  elemental subroutine check_allocation(string)
+    type(string_t), intent(in) ::  string
+    if (.not. allocated(string%string_)) error stop "unallocated"
+  end subroutine
+
+end program
+