From c3190756487080a11e819746f00b6e30fd0a0c2e Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Thu, 27 Jul 2023 14:51:34 +0200
Subject: 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.
---
 gcc/fortran/trans-array.cc                | 18 ++++++++-
 gcc/testsuite/gfortran.dg/finalize_57.f90 | 63 +++++++++++++++++++++++++++++++
 2 files changed, 80 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/finalize_57.f90

(limited to 'gcc')

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index eec62c2..cc50b96 100644
--- 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
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" } }
+
-- 
cgit v1.1