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 --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d965539f11e7071c2e51965af913448fd992b26b..923d46cb47c939fa2eb3beab213cefc98474875b 100644 (file)
--- 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 (file)
index 0000000..a2226e4
--- /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