https://gcc.gnu.org/g:c3190756487080a11e819746f00b6e30fd0a0c2e
commit r15-1094-gc3190756487080a11e819746f00b6e30fd0a0c2e
Author: Andre Vehreschild <ve...@gcc.gnu.org>
Date: Thu Jul 27 14:51:34 2023 +0200
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:
---
gcc/fortran/trans-array.cc | 18 ++++++++-
gcc/testsuite/gfortran.dg/finalize_57.f90 | 63 +++++++++++++++++++++++++++++++
2 files changed, 80 insertions(+), 1 deletion(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index eec62c296ff..cc50b961a97 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 00000000000..b6257357c75
--- /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 <everythingfunctio...@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" } }
+
