Hi all,
The attached patch and new test case provided by Andrew Benson.
Regression tested on x86_64-linux-gnu.
OK for mainline?
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]>
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
