[gcc r17-3317] Fortran: [13-17 regression] Fix duplicated finalization [PR110626]

https://gcc.gnu.org/g:a03222414043b7155a76f7e564fb688ac5ac7bb6

commit r17-3317-ga03222414043b7155a76f7e564fb688ac5ac7bb6
Author: Christopher Albert <[email protected]>
Date:   Sun Aug 16 13:34:44 2026 +0100

    Fortran: [13-17 regression] Fix duplicated finalization [PR110626]
    
    For a derived-type intrinsic assignment with a component defined
    assignment, generate_component_assignments emitted a whole-derived-type
    assignment and a defined-assignment call on a temporary copy of the old
    lhs. The whole assignment finalized the lhs. The INTENT(OUT) argument
    then finalized the stale temporary instead of the real component, so both
    finalizations saw the old value.
    
    For a scalar lhs without pointer or allocatable components, mark the
    whole-derived-type assignment finalize_only. It finalizes the lhs
    without copying the structure, then assigns each component separately.
    The component defined assignment acts on the real component and its
    INTENT(OUT) finalization sees the value left by the first finalization.
    
    Array lhs assignments remain on the existing path because their
    component-wise expansion needs scalarization. The allocatable-component
    case remains PR fortran/57696.
    
    Assisted-by: GPT-5.6-sol (OpenAI)
    Assisted-by: Claude (Anthropic)
    
    2026-08-16  Christopher Albert  <[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.
    
    Signed-off-by: Christopher Albert <[email protected]>

Diff:
---
 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(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5bd8dd50c1c9..b7272de58c89 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 fd8c16d5a6e7..484397da5f8b 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 33b7838f74ac..7656f9784dd0 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 000000000000..045b127ea86a
--- /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