https://gcc.gnu.org/g:1eb696fc092ac39cdb55933b20ee25a99d63b907
commit r16-5178-g1eb696fc092ac39cdb55933b20ee25a99d63b907 Author: Christopher Albert <[email protected]> Date: Fri Nov 7 12:41:42 2025 +0100 fortran: Fix ICE and self-assignment bugs with recursive allocatable finalizers [PR90519] Derived types with recursive allocatable components and FINAL procedures trigger an ICE in gimplify_call_expr because the finalizer wrapper's result symbol references itself (final->result = final), creating a cycle. This patch creates a separate __result_<typename> symbol to break the cycle. Self-assignment (a = a) with such types causes use-after-free because the left-hand side is finalized before copying, destroying the source. This patch adds detection using gfc_dep_compare_expr at compile time and pointer comparison at runtime to skip finalization when lhs == rhs. Parenthesized self-assignment (a = (a)) creates a temporary, defeating the simple self-assignment detection. This patch adds strip_parentheses() to look through INTRINSIC_PARENTHESES operators and ensure deep_copy is enabled for such cases. Test pr112459.f90 now expects 6 _final calls instead of 12 because separate result symbols eliminate double-counting in tree dumps. PR fortran/90519 gcc/fortran/ChangeLog: * trans-expr.cc (strip_parentheses): New helper function to strip INTRINSIC_PARENTHESES operators from expressions. (is_runtime_conformable): Use strip_parentheses to handle cases like a = (a) when checking for self-assignment. (gfc_trans_assignment_1): Strip parentheses before checking if expr2 is a variable, ensuring deep_copy is enabled for cases like a = (a). Also strip parentheses when checking for self-assignment to avoid use-after-free in finalization. (gfc_trans_scalar_assign): Add comment about parentheses handling. * class.cc (generate_finalization_wrapper): Create separate result symbol for finalizer wrapper functions instead of self-referencing the procedure symbol, avoiding ICE in gimplify_call_expr. gcc/testsuite/ChangeLog: * gfortran.dg/finalizer_recursive_alloc_1.f90: New test for ICE fix. * gfortran.dg/finalizer_recursive_alloc_2.f90: New execution test. * gfortran.dg/finalizer_self_assign.f90: New test for self-assignment including a = a, a = (a), and a = (((a))) cases using if/stop pattern. * gfortran.dg/pr112459.f90: Update to expect 6 _final calls instead of 12, reflecting corrected self-assignment behavior. Signed-off-by: Christopher Albert <[email protected]> Diff: --- gcc/fortran/class.cc | 25 ++++- gcc/fortran/trans-expr.cc | 60 +++++++++--- .../gfortran.dg/finalizer_recursive_alloc_1.f90 | 15 +++ .../gfortran.dg/finalizer_recursive_alloc_2.f90 | 32 +++++++ .../gfortran.dg/finalizer_self_assign.f90 | 101 +++++++++++++++++++++ gcc/testsuite/gfortran.dg/pr112459.f90 | 4 +- 6 files changed, 223 insertions(+), 14 deletions(-) diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index a1c6fafa75ef..079240cd2dfe 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -1733,10 +1733,12 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, { gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; + gfc_symbol *result = NULL; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code, *block; char *name; + char *result_name; bool finalizable_comp = false; gfc_expr *ancestor_wrapper = NULL, *rank; gfc_iterator *iter; @@ -1824,7 +1826,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.function = 1; final->attr.pure = 0; final->attr.recursive = 1; - final->result = final; final->ts.type = BT_INTEGER; final->ts.kind = 4; final->attr.artificial = 1; @@ -1832,6 +1833,26 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->attr.if_source = IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; + + /* Create a separate result symbol instead of using final->result = final. + Self-referencing result symbols (final->result = final) create a cycle + in the symbol structure that causes an ICE in gimplify_call_expr when + the finalizer wrapper is used as a procedure pointer initializer. */ + result_name = xasprintf ("__result_%s", tname); + if (gfc_get_symbol (result_name, sub_ns, &result) != 0) + gfc_internal_error ("Failed to create finalizer result symbol"); + free (result_name); + + if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name, + &gfc_current_locus) + || !gfc_add_result (&result->attr, result->name, &gfc_current_locus)) + gfc_internal_error ("Failed to set finalizer result attributes"); + + result->ts = final->ts; + result->attr.artificial = 1; + gfc_set_sym_referenced (result); + gfc_commit_symbol (result); + final->result = result; gfc_set_sym_referenced (final); gfc_commit_symbol (final); @@ -1959,7 +1980,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Set return value to 0. */ last_code = gfc_get_code (EXEC_ASSIGN); - last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr1 = gfc_lval_expr_from_sym (result); last_code->expr2 = gfc_get_int_expr (4, NULL, 0); sub_ns->code = last_code; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 2e88e65b6b87..b87c935a7031 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -11697,7 +11697,17 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts, } gfc_add_block_to_block (&block, &rse->pre); - gfc_add_block_to_block (&block, &lse->finalblock); + + /* Skip finalization for self-assignment. */ + if (deep_copy && lse->finalblock.head) + { + tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location), + gfc_finish_block (&lse->finalblock)); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &lse->finalblock); + gfc_add_block_to_block (&block, &lse->pre); gfc_add_modify (&block, lse->expr, @@ -12683,12 +12693,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, to make sure we do not check for reallocation unneccessarily. */ +/* Strip parentheses from an expression to get the underlying variable. + This is needed for self-assignment detection since (a) creates a + parentheses operator node. */ + +static gfc_expr * +strip_parentheses (gfc_expr *expr) +{ + while (expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + return expr; +} + + static bool is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) { gfc_actual_arglist *a; gfc_expr *e1, *e2; + /* Strip parentheses to handle cases like a = (a). */ + expr1 = strip_parentheses (expr1); + expr2 = strip_parentheses (expr2); + switch (expr2->expr_type) { case EXPR_VARIABLE: @@ -13390,10 +13418,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added - after evaluation of the rhs and before reallocation. */ + after evaluation of the rhs and before reallocation. + Skip finalization for self-assignment to avoid use-after-free. + Strip parentheses from both sides to handle cases like a = (a). */ final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag); - if (final_expr && !(expr2->expr_type == EXPR_VARIABLE - && expr2->symtree->n.sym->attr.artificial)) + if (final_expr + && gfc_dep_compare_expr (strip_parentheses (expr1), + strip_parentheses (expr2)) != 0 + && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE + && strip_parentheses (expr2)->symtree->n.sym->attr.artificial)) { if (lss == gfc_ss_terminator) { @@ -13416,13 +13449,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) - tmp - = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) || scalar_to_array - || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc, - expr1->symtree->n.sym->attr.codimension, - assoc_assign); + { + /* Strip parentheses to detect cases like a = (a) which need deep_copy. */ + gfc_expr *expr2_stripped = strip_parentheses (expr2); + tmp + = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2_stripped) + || scalar_to_array + || expr2->expr_type == EXPR_ARRAY, + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension, + assoc_assign); + } /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 new file mode 100644 index 000000000000..8fe200164b3d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/90519 + +module pr90519_finalizer_mod + implicit none + type :: t + type(t), allocatable :: child + contains + final :: finalize_t + end type t +contains + subroutine finalize_t(self) + type(t), intent(inout) :: self + end subroutine finalize_t +end module pr90519_finalizer_mod diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 new file mode 100644 index 000000000000..6e9edff59d5e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-output " finalizing id\\s+0\\n finalizing id\\s+1\\n finalizer count =\\s+2\\n" } +! PR fortran/90519 + +module pr90519_finalizer_run_mod + implicit none + integer :: finalizer_count = 0 + type :: tree_t + integer :: id = -1 + type(tree_t), allocatable :: child + contains + final :: finalize_tree + end type tree_t +contains + subroutine finalize_tree(self) + type(tree_t), intent(inout) :: self + finalizer_count = finalizer_count + 1 + print *, 'finalizing id', self%id + end subroutine finalize_tree +end module pr90519_finalizer_run_mod + +program test_finalizer + use pr90519_finalizer_run_mod + implicit none + block + type(tree_t) :: root + root%id = 0 + allocate(root%child) + root%child%id = 1 + end block + print *, 'finalizer count =', finalizer_count +end program test_finalizer diff --git a/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 new file mode 100644 index 000000000000..4e5b807df880 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 @@ -0,0 +1,101 @@ +! { dg-do run } +! Test self-assignment with recursive allocatable and finalizer +! This should preserve allocatable components after a = a and a = (a) + +module self_assign_mod + implicit none + type :: node_t + integer :: value = 0 + type(node_t), allocatable :: next + contains + final :: finalize_node + end type node_t +contains + subroutine finalize_node(self) + type(node_t), intent(inout) :: self + end subroutine finalize_node +end module self_assign_mod + +program test_self_assign + use self_assign_mod + implicit none + + call test_simple_self_assign() + call test_parenthesized_self_assign() + call test_triple_parenthesized_self_assign() + call test_array_bounds() + +contains + + subroutine test_simple_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Simple self-assignment should preserve all components + a = a + + if (a%value /= 100) stop 1 + if (.not. allocated(a%next)) stop 2 + if (a%next%value /= 200) stop 3 + end subroutine test_simple_self_assign + + subroutine test_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Parenthesized self-assignment should also preserve all components + a = (a) + + if (a%value /= 100) stop 4 + if (.not. allocated(a%next)) stop 5 + if (a%next%value /= 200) stop 6 + end subroutine test_parenthesized_self_assign + + subroutine test_triple_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Triple-nested parentheses should also work correctly + a = (((a))) + + if (a%value /= 100) stop 7 + if (.not. allocated(a%next)) stop 8 + if (a%next%value /= 200) stop 9 + end subroutine test_triple_parenthesized_self_assign + + subroutine test_array_bounds() + type(node_t), allocatable :: b(:), c(:) + + ! Test array bounds behavior with parentheses. + ! Per F2023:10.2.1.3, lbound((b),1) = 1 even if lbound(b,1) = 5. + ! However, for b = (b) where b is already allocated with the right shape, + ! NO reallocation occurs, so bounds are preserved. + ! For c = (b) where c is unallocated, c gets allocated with default bounds. + allocate(b(5:5)) + b(5)%value = 500 + + ! Self-assignment with parentheses: no reallocation (same shape), bounds preserved + b = (b) + if (.not. allocated(b)) stop 10 + if (lbound(b, 1) /= 5) stop 11 ! Bounds preserved (no realloc) + if (ubound(b, 1) /= 5) stop 12 + if (b(5)%value /= 500) stop 13 + + ! Assignment to unallocated array: gets default (1-based) bounds + c = (b) + if (.not. allocated(c)) stop 14 + if (lbound(c, 1) /= 1) stop 15 ! Default bounds (new allocation) + if (ubound(c, 1) /= 1) stop 16 + if (c(1)%value /= 500) stop 17 + end subroutine test_array_bounds + +end program test_self_assign diff --git a/gcc/testsuite/gfortran.dg/pr112459.f90 b/gcc/testsuite/gfortran.dg/pr112459.f90 index 7db243c224a2..290f915b4877 100644 --- a/gcc/testsuite/gfortran.dg/pr112459.f90 +++ b/gcc/testsuite/gfortran.dg/pr112459.f90 @@ -34,4 +34,6 @@ program myprog print *,"After allocation" end program myprog ! Final subroutines were called with std=gnu and -w = > 14 "_final"s. -! { dg-final { scan-tree-dump-times "_final" 12 "original" } } +! Count reduced from 12 after PR90519 fix - separate result symbols +! disambiguate procedure references from result variables. +! { dg-final { scan-tree-dump-times "_final" 6 "original" } }
