https://gcc.gnu.org/g:b1f99a0d8c4188651a9a32c141896f69cc5a1f98
commit r16-6563-gb1f99a0d8c4188651a9a32c141896f69cc5a1f98 Author: Paul Thomas <[email protected]> Date: Wed Jan 7 16:14:12 2026 +0000 Fortran: [PDT]Fix ICE in tree check and memory leaks[PR90218, PR123071] 2026-01-07 Paul Thomas <[email protected]> gcc/fortran PR fortran/123071 * resolve.cc (resolve_typebound_function): If a generic typebound procedure is marked as overridable and all the specific procedures are non-overridable, it is safe to resolve the compcall. PR fortran/90218 * trans-array.cc (gfc_trans_array_constructor_value): PDT structure constructor elements must be finalized. (trans_array_constructor): Set 'finalize_required' for PDT constructors. * trans-decl.cc (gfc_get_symbol_decl): PDT initialization is required in contained namespaces as long as the parent is not a module. (gfc_init_default_pdt): Delete the stmtblock_t argument. Assign a variable 'value' expression using gfc_trans_assignment. Simplifiy the logic around the call to gfc_init_default_dt. In both cases return a tree expression or null tree. (gfc_trans_deferred_vars): Only call gfc_allocate_pdt_comp if gfc_init_default_pdt returns null tree. * trans-expr.cc (gfc_trans_alloc_subarray_assign): Add a static stmtblock_t pointer 'final_block'. Free 'dest' data pointer and add to final_block. (gfc_conv_structure): Set 'final_block' to the se's finalblock. (gfc_trans_assignment_1): Do not deallocate PDT array ctrs. trans-stmt.cc (gfc_trans_allocate): Also deallocate PDT expr3 allocatable components. (gfc_trans_deallocate): Add PDT deallocation to se.pre instead of block. * trans-stmt.cc (gfc_trans_allocate): Free the allocatable components of a PDT expr3. (gfc_trans_deallocate): Add 'tmp' to se.pre rather than block. gcc/testsuite/ PR fortran/90218 * gfortran.dg/pdt_79.f03: Used uninitialized warning and change tree scan for 'mapped_tensor.j' to 'Pdttensor_t_4.2.j'. * gfortran.dg/pdt_80.f03: New test. Diff: --- gcc/fortran/resolve.cc | 16 +++++++++ gcc/fortran/trans-array.cc | 9 +++++ gcc/fortran/trans-decl.cc | 61 +++++++++++++++++++------------ gcc/fortran/trans-expr.cc | 14 ++++++++ gcc/fortran/trans-stmt.cc | 5 +-- gcc/testsuite/gfortran.dg/pdt_79.f03 | 4 +-- gcc/testsuite/gfortran.dg/pdt_80.f03 | 69 ++++++++++++++++++++++++++++++++++++ 7 files changed, 152 insertions(+), 26 deletions(-) diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index e8a7fcd68570..2e8ce074c246 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -7786,6 +7786,22 @@ resolve_typebound_function (gfc_expr* e) if (!gfc_resolve_ref (e)) return false; + /* It can happen that a generic, typebound procedure is marked as overridable + with all of the specific procedures being non-overridable. If this is the + case, it is safe to resolve the compcall. */ + if (!expr && overridable + && e->value.compcall.tbp->is_generic + && e->value.compcall.tbp->u.generic->specific + && e->value.compcall.tbp->u.generic->specific->non_overridable) + { + gfc_tbp_generic *g = e->value.compcall.tbp->u.generic; + for (; g; g = g->next) + if (!g->specific->non_overridable) + break; + if (g == NULL && resolve_compcall (e, &name)) + return true; + } + /* Get the CLASS declared type. */ declared = get_declared_from_expr (&class_ref, &new_ref, e, true); diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 0b0d50263e9c..46b5c0f77260 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 d7189f48c6bb..8f6819d2f776 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 6ed34619c329..fc82ac11234a 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 42606845cc7e..3433738c3730 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 84d74f8eae59..16b40fe6576c 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 000000000000..ecb6861ee53a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_80.f03 @@ -0,0 +1,69 @@ +! { dg-do run ) +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR90218. The errors that occurred are indicated by the comments below. +! They have all been fixed and the testcase no longer leaks memory. +! +! 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 +! { dg-final { scan-tree-dump-times "__builtin_malloc" 30 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } }
