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.

3 files changed, 41 insertions, 10 deletions

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8f76870..6a00d26 100644
--- 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 ab55940..e619013 100644
--- 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
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
+