[Patch, fortran] PR110626 - [13/14/15/16/17 regression] Duplicated finalization in derived

Paul Richard Thomas <[email protected]>
Newsgroups gmane.comp.gcc.patches,gmane.comp.gcc.fortran
Message-ID <CAGkQGi+L0+=f87=q2qYFXPrhjiczbqGs=U0YqGk-8=MvTgFF+A@mail.gmail.com> 
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
submit.patch (text/x-patch, 8.5 KB) 
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
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.