[patch] Bug 123772 - [OOP] Missed function result finalization when using defined assignment

commit 125081938fa77b27d5124cf0062949e1aeceba46
Author: Jerry DeLisle <[email protected]>
Date:   Fri Jan 23 18:52:34 2026 -0800

    Fortran: Fix missed finalization
    
            PR fortran/123772
    
    gcc/fortran/ChangeLog:
    
            * trans.cc: Add global variable is_assign_call.
            (gfc_finalize_tree_expr): Derived type function results
            with components that have defined assignements are
            handled in resolve.cc(generate_component_assignments), unless
            the assignment was replaced by a subroutine call to the
            subroutine associated with the assignment operator.
            (trans_code): In the case of EXEC_ASSIGN_CALL, set the
            is_asign_call before calling gfc_trans_call, then clear it
            after.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/pr123772.f03: New test.
    
            Signed off by: Andrew Benson <[email protected]>

diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 3221bef09bb..dc74819cced 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -44,6 +44,8 @@ along with GCC; see the file COPYING3.  If not see
 
 const char gfc_msg_fault[] = N_("Array reference out of bounds");
 
+/* Nonzero if we're translating a defined assignment call. */
+int is_assign_call = 0;
 
 /* Advance along TREE_CHAIN n times.  */
 
@@ -1619,14 +1621,17 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *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
-		  || derived->attr.is_iso_c
-		  || derived->attr.is_bind_c
-		  || (derived->attr.extension && derived->f2k_derived
-		      && derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])
-		  || (!derived->attr.extension
-		      && derived->attr.defined_assign_comp)))
+     assignements are handled in resolve.cc(generate_component_assignments),
+     unless the assignment was replaced by a subroutine call to the
+     subroutine associated with the assignment operator. */
+  if ( ! is_assign_call
+       && derived && (derived->attr.is_c_interop
+       || derived->attr.is_iso_c
+       || derived->attr.is_bind_c
+       || (derived->attr.extension && derived->f2k_derived
+	   && derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])
+       || (!derived->attr.extension
+	   && derived->attr.defined_assign_comp)))
     return;
 
   if (is_class)
@@ -2431,8 +2436,12 @@ trans_code (gfc_code * code, tree cond)
 	  break;
 
 	case EXEC_ASSIGN_CALL:
+	  /* Record that an assignment call is being processed, to
+	     ensure finalization occurs in gfc_finalize_tree_expr */
+	  is_assign_call = 1;
 	  res = gfc_trans_call (code, true, NULL_TREE,
 				NULL_TREE, false);
+	  is_assign_call = 0;
 	  break;
 
 	case EXEC_RETURN:
diff --git a/gcc/testsuite/gfortran.dg/pr123772.f03 b/gcc/testsuite/gfortran.dg/pr123772.f03
new file mode 100644
index 00000000000..9dd4fa0f53b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr123772.f03
@@ -0,0 +1,124 @@
+! { dg-do run }
+! Test case provided by Andrew Benson
+module rmm
+  private
+  public :: rm
+
+  type :: rm
+     integer, pointer :: counter => null()
+   contains
+     final     :: rmDestructor
+     procedure :: rmAssign
+     generic   :: assignment(=) => rmAssign
+     procedure :: getCounter => rmGetCounter
+  end type rm
+
+  interface rm
+     module procedure rmConstructor
+  end interface rm
+contains
+  function rmConstructor() result(self)
+    implicit none
+    type(rm) :: self
+    allocate(self%counter)
+    self%counter=1
+    !write (*,'(a,i1)') '  rm construct - count = ',self%counter
+    return
+  end function rmConstructor
+
+  subroutine rmDestructor(self)
+    implicit none
+    type(rm), intent(inout) :: self
+    if (.not.associated(self%counter)) return
+    self%counter=self%counter-1
+    !write (*,'(a,i1)') '  rm destruct - count = ',self%counter
+    nullify(self%counter )
+    return
+  end subroutine rmDestructor
+
+  subroutine rmAssign(to,from)
+    implicit none
+    class(rm), intent(  out) :: to
+    class(rm), intent(in   ) :: from
+    if (associated(from%counter)) then
+       to%counter => from%counter
+       to%counter =  to  %counter+1
+       !write (*,'(a,i1)') '  rm assign - count = ',to%counter
+    else
+       to%counter  => null()
+    end if
+    return
+  end subroutine rmAssign
+
+  integer function rmGetCounter(self)
+    implicit none
+    class(rm), intent(in) :: self
+    rmGetCounter=self%counter
+    return
+  end function rmGetCounter
+end module rmm
+
+module hom
+  use :: rmm, only : rm
+  implicit none
+  private
+  public :: ho
+
+  type ho
+    private
+    type(rm) :: fm
+   contains
+     final     ::                  hoDestructor
+     procedure ::                  hoAssign
+     generic   :: assignment(=) => hoAssign
+     procedure :: getCounter => hoGetCounter
+  end type ho
+
+  interface ho
+     module procedure hoConstructor
+  end interface ho
+contains
+  subroutine hoDestructor(self)
+    implicit none
+    type(ho), intent(inout) :: self
+    !write (*,'(a)') " ho destruct"    
+    return
+  end subroutine hoDestructor
+  
+  subroutine hoAssign(to,from)
+    implicit none
+    class(ho), intent(  out) :: to
+    class(ho), intent(in   ) :: from
+
+    !write (*,'(a)') " ho assign"    
+    to%fm=from%fm
+    return
+  end subroutine hoAssign
+  
+  function hoConstructor() result(self)
+    implicit none
+    type(ho) :: self
+
+    !write (*,'(a)') " ho construct"    
+    self%fm=rm()
+    return
+  end function hoConstructor
+
+  integer function hoGetCounter(self)
+    implicit none
+    class(ho), intent(in) :: self
+    hoGetCounter=self%fm%getCounter()
+    return
+  end function hoGetCounter
+    
+end module hom
+
+program bug
+  use :: hom, only : ho 
+  implicit none
+  type(ho) :: fileObject
+  !write (*,'(a)') "start"
+  fileObject=ho()
+  !write (*,'(a)') "end"  
+  if (fileObject%getCounter() .ne. 1) stop 123
+end program bug