Hello All, This patch by Christopher Albert, with assistance from both GPT and Claude, pushes the suggested limit of ~15 lines sourced from LLMs. However, I think that it is a sufficiently important regression as to be given consideration. I have checked it over and cannot fault it. I reduced the verbosity of the comments somewhat.
OK for all active branches after regression testing on each and a delay between mainline and the others? Cheers Paul
From f6e93e86ab3d199a8a5b19251fabfd7821de42f0 Mon Sep 17 00:00:00 2001 From: Paul Thomas <[email protected]> Date: Mon, 10 Aug 2026 13:34:44 +0100 Subject: [PATCH] Fortran: [13-17 regression] Fix duplicated finalization [PR110626] 2026-10-26 Paul Thomas <[email protected]> gcc/fortran PR fortran/110626 * gfortran.h : Add finalize_only bitfield to gfc_expr. * resolve.cc (generate_component_assignments): If the lhs has no pointer or allocatable components, set use_finalize_only to false. Otherwise it equals finalizable_lhs. Use the value to set the expr1 finalize_only field and add the assignment to the chain. If use_finalize_only is false, free the statements and transfer the value to the final result. * trans-expr.cc (gfc_trans_assignment_1): If expr1 is finalize_ only emit an empty statement. gcc/testsuite/ PR fortran/110626 * gfortran.dg/finalize_62.f90: New test. --- gcc/fortran/gfortran.h | 4 ++ gcc/fortran/resolve.cc | 48 +++++++++++++++-- gcc/fortran/trans-expr.cc | 5 ++ gcc/testsuite/gfortran.dg/finalize_62.f90 | 65 +++++++++++++++++++++++ 4 files changed, 117 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/finalize_62.f90 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5bd8dd50c1c..b7272de58c8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2851,6 +2851,10 @@ typedef struct gfc_expr /* Will require finalization after use. */ unsigned int must_finalize : 1; + /* For a derived-type intrinsic assignment generated by + generate_component_assignments. */ + unsigned int finalize_only : 1; + /* Set this if no range check should be performed on this expression. */ unsigned int no_bounds_check : 1; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index fd8c16d5a6e..484397da5f8 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -13821,6 +13821,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) gfc_expr *tmp_expr = NULL; int error_count, depth; bool finalizable_lhs; + bool use_finalize_only; gfc_get_errors (NULL, &error_count); @@ -13864,6 +13865,24 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) finalizable_lhs = is_finalizable_type ((*code)->expr1->ts); + /* When the lhs is finalized as a whole and none of its components needs the + structure copy to handle it (no pointer or allocatable components), the + copy can be done component by component. The whole-derived-type assignment + then only finalizes the lhs and a component with a defined assignment keeps + its post-finalization value for the INTENT (OUT) finalization in that + defined assignment. */ + use_finalize_only = finalizable_lhs; + if (use_finalize_only) + for (comp1 = (*code)->expr1->ts.u.derived->components; comp1; + comp1 = comp1->next) + if (comp1->attr.pointer || comp1->attr.allocatable + || comp1->attr.proc_pointer_comp || comp1->attr.class_pointer + || comp1->attr.proc_pointer) + { + use_finalize_only = false; + break; + } + /* Create a temporary so that functions get called only once. */ if ((*code)->expr2->expr_type != EXPR_VARIABLE && (*code)->expr2->expr_type != EXPR_CONSTANT) @@ -13900,6 +13919,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) this_code = build_assignment (EXEC_ASSIGN, (*code)->expr1, (*code)->expr2, NULL, NULL, (*code)->loc); + if (use_finalize_only) + this_code->expr1->finalize_only = 1; add_code_to_chain (&this_code, &head, &tail); } @@ -13919,7 +13940,20 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) || comp1->attr.proc_pointer_comp || comp1->attr.class_pointer || comp1->attr.proc_pointer) - continue; + { + /* With finalize_only the whole-derived-type assignment does not copy + the components, so emit the copy for this one here. Only plain + components reach this point, since use_finalize_only excludes + pointer and allocatable components. */ + if (use_finalize_only) + { + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + comp1, comp2, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + continue; + } finalizable_comp = is_finalizable_type (comp1->ts) && !finalizable_lhs; @@ -13961,7 +13995,10 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) && dummy_args->sym->attr.intent == INTENT_OUT; inout = dummy_args && dummy_args->sym->attr.intent == INTENT_INOUT; - if ((inout || finalizable_out) + /* With finalize_only the lhs component keeps its post-finalization + value, so the defined assignment can finalize it directly through + its INTENT (OUT) argument and no temporary is needed. */ + if ((inout || (finalizable_out && !use_finalize_only)) && !comp1->attr.allocatable) { gfc_code *temp_code; @@ -14038,10 +14075,11 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) { /* Don't add intrinsic assignments since they are already effected by the intrinsic assignment of the structure, unless - finalization is required. */ + finalization is required or, with finalize_only, the structure + assignment does not copy the components. */ if (finalizable_comp) this_code->expr1->must_finalize = 1; - else + else if (!use_finalize_only) { gfc_free_statements (this_code); this_code = NULL; @@ -14062,7 +14100,7 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns) add_code_to_chain (&this_code, &head, &tail); - if (t1 && (inout || finalizable_out)) + if (t1 && (inout || (finalizable_out && !use_finalize_only))) { /* Transfer the value to the final result. */ this_code = build_assignment (EXEC_ASSIGN, diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 33b7838f74a..7656f9784dd 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -13684,6 +13684,11 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, && assoc_assign) tmp = gfc_trans_pointer_assignment (expr1, expr2); + /* The finalization above is all that is wanted: the structure copy is done + component by component in generate_component_assignments. */ + if (expr1->finalize_only) + tmp = build_empty_stmt (input_location); + /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) { diff --git a/gcc/testsuite/gfortran.dg/finalize_62.f90 b/gcc/testsuite/gfortran.dg/finalize_62.f90 new file mode 100644 index 00000000000..045b127ea86 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_62.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR fortran/110626 - in a derived-type intrinsic assignment, a finalizable +! component that has a defined assignment is finalized twice: once by the +! whole-derived-type finalization of the lhs and once by the INTENT(OUT) +! argument of the defined assignment. The second finalization must see the +! value left by the first one, not a stale copy, matching other compilers. +! +module pr110626 + implicit none + + type :: cell + integer :: tag = 0 + contains + final :: wipe + procedure :: copyinto + generic :: assignment(=) => copyinto + end type + + type :: box + type(cell) :: c + end type + + integer :: nf = 0 + integer :: ncopy = 0 + integer :: seen_final(4) = 0 + integer :: seen_copy = -99 + +contains + + subroutine wipe (self) + type(cell), intent(inout) :: self + nf = nf + 1 + if (nf <= size (seen_final)) seen_final(nf) = self%tag + self%tag = -1 + end subroutine + + subroutine copyinto (dst, src) + class(cell), intent(out) :: dst + type(cell), intent(in) :: src + ncopy = ncopy + 1 + seen_copy = dst%tag + dst%tag = src%tag + 1 + end subroutine + +end module + +program p + use pr110626 + implicit none + type(box) :: src, dst + + src%c%tag = 7 + dst%c%tag = 42 + + nf = 0; ncopy = 0 + dst = src + + if (nf /= 2) stop 1 ! two finalizations of the old component + if (seen_final(1) /= 42) stop 2 ! first sees the old value + if (seen_final(2) /= -1) stop 3 ! second sees the post-finalization value + if (ncopy /= 1) stop 4 ! defined assignment runs once + if (seen_copy /= 0) stop 5 ! INTENT(OUT) default-initialised before body + if (dst%c%tag /= 8) stop 6 ! result is src + 1 +end program -- 2.55.0
