Implements Fortran 2003 4.5.5.2 finalization rule: function results are finalized after execution of the innermost executable construct. Fixes constructor/finalizer ICE for non-allocatable types. PR 121472
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=121472
>From a73c2aae65177b32ddb176c6e23078b7854ed7a1 Mon Sep 17 00:00:00 2001 From: Christopher Albert <[email protected]> Date: Tue, 2 Dec 2025 21:22:07 +0100 Subject: [PATCH] fortran: Finalize function results per F2003 4.5.5.2 Implements Fortran 2003 4.5.5.2 finalization rule: function results are finalized after execution of the innermost executable construct. Fixes constructor/finalizer ICE for non-allocatable types. PR fortran/121472 gcc/fortran/ChangeLog: * resolve.cc (resolve_ordinary_assign): Mark function results for finalization when used in assignments. * trans-array.cc (gfc_trans_create_temp_array): Finalize temporary arrays for function results. * trans-expr.cc (gfc_conv_procedure_call): Skip finalization for expressions marked must_finalize. Finalize deferred RHS function actuals. (gfc_trans_assignment_1): Update finalization logic for function expressions. * trans.cc (gfc_derived_needs_copy): New function to check for actual allocatable components. (gfc_finalize_tree_expr): Skip finalization for unevaluated CALL_EXPR with no actual allocatable components. gcc/testsuite/ChangeLog: * gfortran.dg/finalize_45.f90: Update comment. * gfortran.dg/finalize_constructor_1.f90: New test. Signed-off-by: Christopher Albert <[email protected]> --- gcc/fortran/resolve.cc | 28 +++++++ gcc/fortran/trans-array.cc | 37 ++++++++++ gcc/fortran/trans-expr.cc | 43 +++++++---- gcc/fortran/trans.cc | 44 ++++++++++- gcc/testsuite/gfortran.dg/finalize_45.f90 | 4 +- .../gfortran.dg/finalize_constructor_1.f90 | 73 +++++++++++++++++++ 6 files changed, 209 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/finalize_constructor_1.f90 diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index db6b52f3076..112776a2230 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -12942,6 +12942,34 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) *rhsptr = gfc_get_parentheses (*rhsptr); + /* For user-defined assignment, if RHS is a function returning a + finalizable non-allocatable, non-pointer derived-type result, mark it + for finalization per F2018 7.5.6.3. Allocatable or pointer function + results handle their own finalization semantics and must not be + finalized here to avoid double finalization. */ + if (*rhsptr && (*rhsptr)->expr_type == EXPR_FUNCTION + && gfc_may_be_finalized ((*rhsptr)->ts) + && (*rhsptr)->symtree->n.sym->result) + { + bool allocatable_or_pointer = false; + gfc_symbol *result_sym; + + result_sym = (*rhsptr)->symtree->n.sym->result; + + if (result_sym->ts.type == BT_CLASS + && CLASS_DATA (result_sym)) + allocatable_or_pointer + = (CLASS_DATA (result_sym)->attr.allocatable + || CLASS_DATA (result_sym)->attr.pointer); + else + allocatable_or_pointer + = (result_sym->attr.allocatable + || result_sym->attr.pointer); + + if (!allocatable_or_pointer) + (*rhsptr)->must_finalize = 1; + } + return true; } diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index cd137212260..579a9e2032c 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1797,6 +1797,43 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial, dynamic, dealloc); + /* PR121472: Finalize function result temps per F2018 7.5.6.3. */ + if (dealloc && ss->info && ss->info->type == GFC_SS_FUNCTION + && ss->info->expr + && (ss->info->expr->ts.type == BT_DERIVED + || ss->info->expr->ts.type == BT_CLASS) + && gfc_may_be_finalized (ss->info->expr->ts)) + { + gfc_se fin_se; + stmtblock_t fin_block; + symbol_attribute attr; + gfc_symbol *derived = NULL; + + gfc_init_block (&fin_block); + gfc_init_se (&fin_se, NULL); + fin_se.expr = desc; + + attr = gfc_expr_attr (ss->info->expr); + attr.pointer = 0; + attr.allocatable = 0; + + if (ss->info->expr->ts.type == BT_DERIVED) + derived = ss->info->expr->ts.u.derived; + else if (ss->info->expr->ts.type == BT_CLASS) + derived = CLASS_DATA (ss->info->expr)->ts.u.derived; + + if (derived) + { + gfc_finalize_tree_expr (&fin_se, derived, attr, ss->dimen); + gfc_add_block_to_block (&fin_block, &fin_se.pre); + gfc_add_block_to_block (&fin_block, &fin_se.finalblock); + gfc_add_block_to_block (&fin_block, &fin_se.post); + + if (fin_block.head) + gfc_prepend_expr_to_block (post, gfc_finish_block (&fin_block)); + } + } + while (ss->parent) ss = ss->parent; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index ac85b762c7f..b686c15e90a 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7575,9 +7575,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, stmtblock_t *class_pre_block = defer_to_dealloc_blk ? &dealloc_blk : &parmse.pre; - gfc_add_block_to_block (class_pre_block, &class_se.pre); - gfc_add_block_to_block (&parmse.post, &class_se.post); - } + gfc_add_block_to_block (class_pre_block, &class_se.pre); + gfc_add_block_to_block (&parmse.post, &class_se.post); + } if (fsym && (fsym->ts.type == BT_DERIVED || fsym->ts.type == BT_ASSUMED) @@ -8803,7 +8803,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, bool finalizable = der != NULL && der->ns->proc_name && gfc_is_finalizable (der, NULL); - if (!byref && finalizable) + if (!byref && finalizable + && !(expr && expr->must_finalize)) gfc_finalize_tree_expr (se, der, attr, expr->rank); if (!byref && sym->ts.type != BT_CHARACTER @@ -8870,7 +8871,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Bundle in the string length. */ se->string_length = len; - if (finalizable) + if (finalizable + && !(expr && expr->must_finalize)) gfc_finalize_tree_expr (se, der, attr, expr->rank); } else if (ts.type == BT_CHARACTER) @@ -8977,6 +8979,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && attr.pointer)) gfc_finalize_tree_expr (se, NULL, attr, expr->rank); } + /* For RHS function actuals marked for deferred finalization in + user-defined assignments and intrinsic assignments, finalize after + the call returns per ISO/IEC 1539-1:2018 7.5.6.3. */ + else if (expr && expr->expr_type == EXPR_FUNCTION + && expr->ts.type == BT_DERIVED + && expr->must_finalize + && gfc_is_finalizable (expr->ts.u.derived, NULL)) + { + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + attr = expr->value.function.esym + ? expr->value.function.esym->result->attr + : expr->symtree->n.sym->attr; + if (!attr.pointer) + gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, expr->rank); + } gfc_add_block_to_block (&se->post, &post); } @@ -13073,12 +13091,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, && (gfc_expr_attr (expr2).pointer || (expr2->ts.type == BT_CLASS && CLASS_DATA (expr2)->attr.class_pointer))) expr2->must_finalize = 0; - /* F2008 4.5.6.3 para 5: If an executable construct references a - structure constructor or array constructor, the entity created by - the constructor is finalized after execution of the innermost - executable construct containing the reference. - These finalizations were later deleted by the Combined Techical - Corrigenda 1 TO 4 for fortran 2008 (f08/0011). */ + /* F2008 4.5.6.3 para 5: Structure/array constructor finalization was + deleted by f08/0011. For backward compatibility with -std=f2008, + continue finalizing constructors unless the corrected behavior is + requested via gfc_notification_std (GFC_STD_F2018_DEL). */ else if (gfc_notification_std (GFC_STD_F2018_DEL) && (expr2->expr_type == EXPR_STRUCTURE || expr2->expr_type == EXPR_ARRAY)) @@ -13470,10 +13486,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&body, tmp); /* Add the post blocks to the body. Scalar finalization must appear before - the post block in case any dellocations are done. */ + the post block in case any dellocations are done. PR121472. */ if (rse.finalblock.head - && (!l_is_temp || (expr2->expr_type == EXPR_FUNCTION - && gfc_expr_attr (expr2).elemental))) + && (!l_is_temp || expr2->expr_type == EXPR_FUNCTION)) { gfc_add_block_to_block (&body, &rse.finalblock); gfc_add_block_to_block (&body, &rse.post); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 47396c3cbab..4bba4af5ec2 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1602,7 +1602,38 @@ gfc_assignment_finalizer_call (gfc_se *lse, gfc_expr *expr1, bool init_flag) } -/* Finalize a TREE expression using the finalizer wrapper. The result is +/* PR121472: Check if type has actual allocatable components. */ + +static bool +gfc_derived_needs_copy (gfc_symbol *derived) +{ + gfc_component *c; + + if (!derived || !derived->components) + return false; + + for (c = derived->components; c; c = c->next) + { + /* Direct allocatable component. */ + if (c->attr.allocatable) + return true; + + /* Recursively check derived type components. */ + if (c->ts.type == BT_DERIVED + && gfc_derived_needs_copy (c->ts.u.derived)) + return true; + + /* Class components with allocatable data. */ + if (c->ts.type == BT_CLASS + && CLASS_DATA (c)->attr.allocatable) + return true; + } + + return false; +} + + +/* Finalize a TREE expression using the finalizer wrapper. The result is fixed in order to prevent repeated calls. */ void @@ -1618,6 +1649,13 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, if (attr.pointer) return; + /* PR121472: Skip finalization for unevaluated CALL_EXPR with transitive + alloc_comp but no actual allocatable components to avoid ICE. */ + if (se->expr && TREE_CODE (se->expr) == CALL_EXPR + && derived && derived->attr.alloc_comp + && !gfc_derived_needs_copy (derived)) + return; + /* Derived type function results with components that have defined assignements are handled in resolve.cc(generate_component_assignments) */ if (derived && (derived->attr.is_c_interop @@ -1648,7 +1686,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, else if (se->direct_byref) { desc = gfc_evaluate_now (se->expr, &se->finalblock); - if (derived->attr.alloc_comp) + if (derived->attr.alloc_comp && gfc_derived_needs_copy (derived)) { /* Need to copy allocated components and not finalize. */ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0); @@ -1659,7 +1697,7 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, { desc = gfc_evaluate_now (se->expr, &se->pre); se->expr = gfc_evaluate_now (desc, &se->pre); - if (derived->attr.alloc_comp) + if (derived->attr.alloc_comp && gfc_derived_needs_copy (derived)) { /* Need to copy allocated components and not finalize. */ tmp = gfc_copy_alloc_comp_no_fini (derived, se->expr, desc, rank, 0); diff --git a/gcc/testsuite/gfortran.dg/finalize_45.f90 b/gcc/testsuite/gfortran.dg/finalize_45.f90 index 0819cf6e168..79b5c66e88d 100644 --- a/gcc/testsuite/gfortran.dg/finalize_45.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_45.f90 @@ -122,9 +122,7 @@ contains call foo%clean() -! NAGFOR has assoc_counts =2, which is probably correct. If nullification -! of the pointer component is not done in gfortran, function finalization -! results in a double free. TODO fix this. +! Function result finalization per Fortran 2018 Section 7.5.6.3. if (final_counts /= 2) stop 3 if (assoc_counts /= 2) stop 4 end diff --git a/gcc/testsuite/gfortran.dg/finalize_constructor_1.f90 b/gcc/testsuite/gfortran.dg/finalize_constructor_1.f90 new file mode 100644 index 00000000000..ea95d0707a2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_constructor_1.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! { dg-output " constructor: *1(\n|\r\n|\r)" } +! { dg-output " finalizer: *2(\n|\r\n|\r)" } +! PR fortran/121472 +! Test that derived types with finalizers and constructor interfaces compile +! without ICE and produce ISO F2018 compliant finalization behavior. +! +! ISO/IEC 1539-1:2018 Section 7.5.6.3 paragraph 3: +! "Finalization occurs ... (3) when an intrinsic assignment statement is +! executed and ... the variable is of a finalizable type, the variable is +! finalized after evaluation of expr and before the definition of the variable." +! +! For the statement: obj = container_t() +! +! Expected finalization count: 2 +! (1) Function result from container_t() after assignment per 7.5.6.3(3) +! (2) Variable obj at end of scope per 7.5.6.3(1) +! +! Expected constructor count: 1 +! (1) Call to container_constructor via container_t() +! +! This used to trigger an internal compiler error in gimplify_expr because +! finalization was attempted on unevaluated CALL_EXPR nodes for types with +! non-allocatable components but transitive alloc_comp marking. +! +! Contributed by Andrew Benson + +module pr121472_m + implicit none + + integer :: constructor_count = 0 + integer :: finalizer_count = 0 + + type :: base_t + end type base_t + + type :: container_t + type(base_t) :: component + contains + final :: container_finalize + end type container_t + + interface container_t + module procedure container_constructor + end interface container_t + +contains + + subroutine container_finalize(this) + type(container_t), intent(inout) :: this + finalizer_count = finalizer_count + 1 + end subroutine container_finalize + + function container_constructor() result(res) + type(container_t) :: res + constructor_count = constructor_count + 1 + end function container_constructor + +end module pr121472_m + +program test_finalize_constructor + use pr121472_m + implicit none + + type(container_t) :: obj + + ! This assignment from constructor used to cause ICE + obj = container_t() + + print *, 'constructor:', constructor_count + print *, 'finalizer:', finalizer_count + +end program test_finalize_constructor -- 2.52.0
