https://gcc.gnu.org/g:43c11931acc50f3a44efb485b03e6a8d44df97e0
commit r15-7789-g43c11931acc50f3a44efb485b03e6a8d44df97e0
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Wed Feb 26 14:30:13 2025 +0100
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:
---
gcc/fortran/trans-array.cc | 11 ++++-----
gcc/fortran/trans-expr.cc | 13 ++++++++---
.../gfortran.dg/alloc_comp_auto_array_4.f90 | 27 ++++++++++++++++++++++
3 files changed, 41 insertions(+), 10 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8f76870b286a..6a00d26cb2f3 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 ab55940638e2..e619013f261e 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 000000000000..06bd8b50b967
--- /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
+
