https://gcc.gnu.org/g:3c4ca61fa09ee25d0bba4ec1124a82573d91df47
commit r16-7017-g3c4ca61fa09ee25d0bba4ec1124a82573d91df47 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: --- gcc/fortran/trans.cc | 25 ++++--- gcc/testsuite/gfortran.dg/pr123772.f03 | 124 +++++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 3221bef09bb0..dc74819cced5 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 000000000000..9dd4fa0f53be --- /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
