https://gcc.gnu.org/g:0f344846a62c8863375909d8d6b435b4b5fd35a0
commit r15-8481-g0f344846a62c8863375909d8d6b435b4b5fd35a0
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Thu Mar 20 13:37:21 2025 +0100
Fortran: Fix double free on polymorphic array dummy argument [PR119349]
Calling elemental routines with polymorphic formals leads to generation
of a temporary polymorphic variable and code for its deallocation.
Sourcing this element from an array constructor the latter now is
prevented from generating a second deallocation.
PR fortran/119349
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_conv_procedure_call): Prevent deallocation
of array temporary for polymorphic temporary argument.
gcc/testsuite/ChangeLog:
* gfortran.dg/class_79.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc | 6 +++++-
gcc/testsuite/gfortran.dg/class_79.f90 | 25 +++++++++++++++++++++++++
2 files changed, 30 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d965539f11e7..923d46cb47c9 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7994,7 +7994,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->post, local_tmp);
}
- if (!finalized && !e->must_finalize)
+ /* Items of array expressions passed to a polymorphic formal arguments
+ create their own clean up, so prevent double free. */
+ if (!finalized && !e->must_finalize
+ && !(e->expr_type == EXPR_ARRAY && fsym
+ && fsym->ts.type == BT_CLASS))
{
bool scalar_res_outside_loop;
scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
diff --git a/gcc/testsuite/gfortran.dg/class_79.f90
b/gcc/testsuite/gfortran.dg/class_79.f90
new file mode 100644
index 000000000000..a2226e47aff3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_79.f90
@@ -0,0 +1,25 @@
+!{ dg-do run }
+
+! Check double free on array constructor in argument list is fixed.
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+program pr119349
+ implicit none
+
+ type string_t
+ character(len=:), allocatable :: string_
+ end type
+
+ print *, true([string()])
+
+contains
+
+ type(string_t) function string()
+ string%string_ = ""
+ end function
+
+ logical elemental function true(rhs)
+ class(string_t), intent(in) :: rhs
+ true = .true.
+ end function
+
+end program
