Add finalizer creation to array constructor for functions of derived type.

	PR fortran/90068

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_ctor_element): Eval non-
	variable expressions once only.
	(gfc_trans_array_constructor_value): Add statements of
	final block.
	(trans_array_constructor): Detect when final block is required.

gcc/testsuite/ChangeLog:

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

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index eec62c296ff5073b80b246ad73caa5c839bdd800..cc50b961a97905bd6373d34a9f0554fb5a7c9ed8 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1885,6 +1885,16 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
                                 gfc_conv_descriptor_data_get (desc));
   tmp = gfc_build_array_ref (tmp, offset, NULL);
 
+  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));
+    }
+
   if (expr->ts.type == BT_CHARACTER)
     {
       int i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
@@ -2147,6 +2157,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
              *poffset = fold_build2_loc (input_location, PLUS_EXPR,
                                          gfc_array_index_type,
                                          *poffset, gfc_index_one_node);
+             if (finalblock)
+               gfc_add_block_to_block (finalblock, &se.finalblock);
            }
          else
            {
@@ -2795,6 +2807,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
   tree neg_len;
   char *msg;
   stmtblock_t finalblock;
+  bool finalize_required;
 
   /* Save the old values for nested checking.  */
   old_first_len = first_len;
@@ -2973,8 +2986,11 @@ trans_array_constructor (gfc_ss * ss, locus * where)
   TREE_USED (offsetvar) = 0;
 
   gfc_init_block (&finalblock);
+  finalize_required = expr->must_finalize;
+  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+    finalize_required = true;
   gfc_trans_array_constructor_value (&outer_loop->pre,
-                                    expr->must_finalize ? &finalblock : NULL,
+                                    finalize_required ? &finalblock : NULL,
                                     type, desc, c, &offset, &offsetvar,
                                     dynamic);
 

diff --git a/gcc/testsuite/gfortran.dg/finalize_57.f90 b/gcc/testsuite/gfortran.dg/finalize_57.f90
new file mode 100644 (file)
index 0000000..b625735
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_57.f90
@@ -0,0 +1,63 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/90068
+!
+! Contributed by Brad Richardson  <everythingfunctional@protonmail.com>
+! 
+
+program array_memory_leak
+    implicit none
+
+    type, abstract :: base
+    end type base
+
+    type, extends(base) :: extended
+    end type extended
+
+    type :: container
+        class(base), allocatable :: thing
+    end type
+
+    type, extends(base) :: collection
+        type(container), allocatable :: stuff(:)
+    end type collection
+
+    call run()
+    call bad()
+contains
+    subroutine run()
+        type(collection) :: my_thing
+        type(container) :: a_container
+
+        a_container = newContainer(newExtended()) ! This is fine
+        my_thing = newCollection([a_container])
+    end subroutine run
+
+    subroutine bad()
+        type(collection) :: my_thing
+
+        my_thing = newCollection([newContainer(newExtended())]) ! This is a memory leak
+    end subroutine bad
+
+    function newExtended()
+        type(extended) :: newExtended
+    end function newExtended
+
+    function newContainer(thing)
+        class(base), intent(in) :: thing
+        type(container) :: newContainer
+
+        allocate(newContainer%thing, source = thing)
+    end function newContainer
+
+    function newCollection(things)
+        type(container), intent(in) :: things(:)
+        type(collection) :: newCollection
+
+        newCollection%stuff = things
+    end function newCollection
+end program array_memory_leak
+
+! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } }
+