Hi All,
I just noticed that the testcase, pdt_80.f03, was not in the patch. Please
find attached the updated patch.
Paul
On Mon, 5 Jan 2026 at 16:30, Paul Richard Thomas <
[email protected]> wrote:
> Hi All,
>
> This PR was largely fixed by preceding patches, insofar as it ran and
> produced the expected output, apart from the explicit initialization
> expressions for the PDT entities. However, the testcase leaked memory like
> a sieve and it has taken a while to sort out a satisfactory fix.
>
> The chunks in trans-decl.cc implement the fix for the explicit
> initialization of PDT entities. This part is straightforward.
>
> The rest of the patch is devoted to fixing the memory leaks triggered by
> the new testcase. The problem was associated with pdt_arrays embedded in
> PDT structure constructors, which themselves were embedded in array
> constructors that were part of a PDT constructor.... if you see what I mean
> :-) The original pdt_arrays are copied into a destination array, which is
> implicitly allocated by gfc_duplicate_allocatable. The allocated memory was
> being lost in the subsequent copy of the enclosing array constructor.
> Rescuing and freeing the memory is accomplished using the finalization
> block, which is then executed after the copy of the array constructor. Note
> that these frees are not guarded. I don't believe that there is any
> circumstance where this will be an issue but, if required, it would be
> easily implemented.
>
> The chunks in trans-stmt.cc pick up memory leaks in allocation and
> deallocation. As a side effect, the leak in pdt_3.f03 is fixed. PR121972
> will be updated accordingly, since pdt_39/70/77.f03 still leak memory.
>
> Regtests on FC43/x86_64. OK for mainline
>
> Paul
>
>
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0b0d50263e9..46b5c0f7726 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -2248,6 +2248,11 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
{
/* Scalar values. */
gfc_init_se (&se, NULL);
+ if (c->expr->ts.type == BT_DERIVED
+ && c->expr->ts.u.derived->attr.pdt_type
+ && c->expr->expr_type == EXPR_STRUCTURE)
+ c->expr->must_finalize = 1;
+
gfc_trans_array_ctor_element (&body, desc, *poffset,
&se, c->expr);
@@ -3088,6 +3093,10 @@ trans_array_constructor (gfc_ss * ss, locus * where)
finalize_required = expr->must_finalize;
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
finalize_required = true;
+
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type)
+ finalize_required = true;
+
gfc_trans_array_constructor_value (&outer_loop->pre,
finalize_required ? &finalblock : NULL,
type, desc, c, &offset, &offsetvar,
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index d7189f48c6b..8f6819d2f77 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1711,12 +1711,16 @@ gfc_get_symbol_decl (gfc_symbol * sym)
declaration of the entity and memory allocated/deallocated. */
if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
&& sym->param_list != NULL
- && gfc_current_ns == sym->ns
+ && (gfc_current_ns == sym->ns
+ || (gfc_current_ns == sym->ns->parent
+ && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
if ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_comp)
- && gfc_current_ns == sym->ns
+ && (gfc_current_ns == sym->ns
+ || (gfc_current_ns == sym->ns->parent
+ && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
&& !(sym->attr.use_assoc || sym->attr.dummy))
gfc_defer_symbol_init (sym);
@@ -4596,25 +4600,37 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc,
}
-/* Initialize a PDT, when all the components have an initializer. */
-static void
-gfc_init_default_pdt (gfc_symbol *sym, stmtblock_t *block, bool dealloc)
+/* Initialize a PDT, either when the symbol has a value or when all the
+ components have an initializer. */
+static tree
+gfc_init_default_pdt (gfc_symbol *sym, bool dealloc)
{
- /* Allowed in the case where all the components have initializers and
- there are no LEN components. */
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type)
+ stmtblock_t block;
+ tree tmp;
+ gfc_component *c;
+
+ if (sym->value && sym->value->symtree
+ && sym->value->symtree->n.sym
+ && !sym->value->symtree->n.sym->attr.artificial)
{
- gfc_component *c = sym->ts.u.derived->components;
- if (!dealloc || !sym->value || sym->value->expr_type != EXPR_STRUCTURE)
- return;
- for (; c; c = c->next)
- if (c->attr.pdt_len || !c->initializer)
- return;
+ tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym),
+ sym->value, false, false, true);
+ return tmp;
}
- else
- return;
- gfc_init_default_dt (sym, block, dealloc, true);
- return;
+
+ if (!dealloc || !sym->value)
+ return NULL_TREE;
+
+ /* Allowed in the case where all the components have initializers and
+ there are no LEN components. */
+ c = sym->ts.u.derived->components;
+ for (; c; c = c->next)
+ if (c->attr.pdt_len || !c->initializer)
+ return NULL_TREE;
+
+ gfc_init_block (&block);
+ gfc_init_default_dt (sym, &block, dealloc, true);
+ return gfc_finish_block (&block);
}
@@ -4998,9 +5014,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
is_pdt_type = true;
gfc_init_block (&tmpblock);
+
if (!sym->attr.dummy && !sym->attr.pointer)
{
- if (!sym->attr.allocatable)
+ tmp = gfc_init_default_pdt (sym, true);
+ if (!sym->attr.allocatable && tmp == NULL_TREE)
{
tmp = gfc_allocate_pdt_comp (sym->ts.u.derived,
sym->backend_decl,
@@ -5008,9 +5026,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
sym->param_list);
gfc_add_expr_to_block (&tmpblock, tmp);
}
-
- if (is_pdt_type)
- gfc_init_default_pdt (sym, &tmpblock, true);
+ else if (tmp != NULL_TREE)
+ gfc_add_expr_to_block (&tmpblock, tmp);
if (!sym->attr.result && !sym->ts.u.derived->attr.alloc_comp)
tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived,
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6ed34619c32..fc82ac11234 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9609,6 +9609,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
}
+static stmtblock_t *final_block;
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
@@ -9680,6 +9681,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
+ if (final_block && expr->expr_type == EXPR_ARRAY)
+ {
+ tree data_ptr;
+ data_ptr = gfc_conv_descriptor_data_get (dest);
+ gfc_add_expr_to_block (final_block, gfc_call_free (data_ptr));
+ }
+
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr,
null_pointer_node);
@@ -10385,6 +10393,10 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
if (!init)
{
+ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.pdt_type
+ && expr->must_finalize)
+ final_block = &se->finalblock;
+
/* Create a temporary variable and fill it in. */
se->expr = gfc_create_var (type, expr->ts.u.derived->name);
/* The symtree in expr is NULL, if the code to generate is for
@@ -10392,6 +10404,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
tmp = gfc_trans_structure_assign (se->expr, expr, expr->symtree != NULL,
se->want_coarray);
gfc_add_expr_to_block (&se->pre, tmp);
+ final_block = NULL;
return;
}
@@ -13291,6 +13304,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Deallocate the lhs parameterized components if required. */
if (dealloc
&& !expr1->symtree->n.sym->attr.associate_var
+ && expr2->expr_type != EXPR_ARRAY
&& ((expr1->ts.type == BT_DERIVED
&& expr1->ts.u.derived
&& expr1->ts.u.derived->attr.pdt_type)
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 42606845cc7..3433738c373 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6926,7 +6926,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
if ((code->expr3->ts.type == BT_DERIVED
|| code->expr3->ts.type == BT_CLASS)
&& (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
- && code->expr3->ts.u.derived->attr.alloc_comp
+ && (code->expr3->ts.u.derived->attr.alloc_comp
+ || code->expr3->ts.u.derived->attr.pdt_type)
&& !code->expr3->must_finalize
&& !code->ext.alloc.expr3_not_explicit)
{
@@ -7975,7 +7976,7 @@ gfc_trans_deallocate (gfc_code *code)
se.expr, expr->rank);
if (tmp)
- gfc_add_expr_to_block (&block, tmp);
+ gfc_add_expr_to_block (&se.pre, tmp);
if (flag_coarray == GFC_FCOARRAY_LIB
|| flag_coarray == GFC_FCOARRAY_SINGLE)
diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03
index 84d74f8eae5..16b40fe6576 100644
--- a/gcc/testsuite/gfortran.dg/pdt_79.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_79.f03
@@ -54,8 +54,8 @@ contains
if (mt%k /= 4) stop 3
if (mt%j /= 42) stop 4
end associate
- end subroutine
+ end subroutine ! { dg-warning ".mapped_tensor. is used uninitialized" }
end
-! { dg-final { scan-tree-dump-times "mapped_tensor.j = 42" 1 "original" } }
+! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } }
! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_80.f03 b/gcc/testsuite/gfortran.dg/pdt_80.f03
new file mode 100644
index 00000000000..229d20317a7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_80.f03
@@ -0,0 +1,63 @@
+! { dg-do run )
+!
+! Contributed by Arseny Solokha <[email protected]>
+!
+ type :: foo(a)
+ integer,len :: a
+ integer :: vals(a)
+ end type
+ type :: bar(b)
+ integer,len :: b
+ type(foo(2)) :: array(b)
+ end type
+
+ type :: barbar(b)
+ integer,len :: b
+ type(foo(2)), allocatable :: array(:)
+ end type
+
+
+ type(barbar(2)) :: var2
+ type(bar(2)) :: var = bar(2)([foo(2)([1,2]),foo(2)([3,4])]) ! Values were not set
+
+ if (any (var%array%vals(1) /= [1,3])) stop 1
+ if (any (var%array%vals(2) /= [2,4])) stop 2
+
+ var = bar(2)([foo(2)(-[1,2]),foo(2)(-[3,4])]) ! Was OK but 16bytes/2 blocks lost
+
+ var%array = [foo(2)([5,6]),foo(2)([7,8])] ! Was an invalid free here
+ ! also 16bytes/2 blocks lost
+ if (any (var%array%vals(1) /= [5,7])) stop 3
+ if (any (var%array%vals(2) /= [6,8])) stop 4
+
+ var2 = barbar(2)([foo(2)([1,2]),foo(2)([3,4])]) ! 16bytes/2 blocks lost
+
+ if (any (var2%array%vals(1) /= [1,3])) stop 5
+ if (any (var2%array%vals(2) /= [2,4])) stop 6
+ if (allocated (var2%array)) deallocate (var2%array) ! Caused gimplifier problems
+
+ call foobar
+
+contains
+ subroutine foobar
+ type(barbar(2)) :: var_s2
+ type(bar(2)) :: var_s = bar(2)([foo(2)([1,2]),foo(2)([3,4])]) ! Values were not set
+
+ if (any (var_s%array%vals(1) /= [1,3])) stop 1
+ if (any (var_s%array%vals(2) /= [2,4])) stop 2
+
+ var_s = bar(2)([foo(2)(-[1,2]),foo(2)(-[3,4])]) ! Was OK but 16bytes/2 blocks lost
+
+ var_s%array = [foo(2)([5,6]),foo(2)([7,8])] ! Was an invalid free here
+ ! also 16bytes/2 blocks lost
+ if (any (var_s%array%vals(1) /= [5,7])) stop 3
+ if (any (var_s%array%vals(2) /= [6,8])) stop 4
+
+ var_s2 = barbar(2)([foo(2)([1,2]),foo(2)([3,4])]) ! 16bytes/2 blocks lost
+
+ if (any (var_s2%array%vals(1) /= [1,3])) stop 5
+ if (any (var_s2%array%vals(2) /= [2,4])) stop 6
+ if (allocated (var_s2%array)) deallocate (var_s2%array) ! Caused gimplifier problems
+ end
+
+end ! 160bytes/1 block was lost here
