https://gcc.gnu.org/g:b405a04ffde07e9a3021b74a5d40c7938984b88f
commit r16-6656-gb405a04ffde07e9a3021b74a5d40c7938984b88f Author: Jerry DeLisle <[email protected]> Date: Fri Jan 9 09:38:52 2026 -0800 Fortran: [PR123483] Fix duplicate finalization A duplicated call to a finalizer occured in cases where a derived type has components, one or more of which are allocatable, and one or more of which are finalizable. (The bug occured only if the derived type is an extension of another type, which has defined assignment.) New test case derived from the original report by Paul Thomas. PR fortran/123483 gcc/fortran/ChangeLog: * trans-array.cc (gfc_deallocate_alloc_comp): Ad the new finalization argument and pass it to structure_alloc_comps. * trans-array.h (gfc_deallocate_alloc_comp): Add a finalization flag that can be passed by gfc_conv_procedure_call. * trans-expr.cc (gfc_conv_procedure_call): Use the new finalization flag. gcc/testsuite/ChangeLog: * gfortran.dg/finalize_61.f90: New test. Signed off by: Andrew Benson <[email protected]> Diff: --- gcc/fortran/trans-array.cc | 4 +- gcc/fortran/trans-array.h | 3 +- gcc/fortran/trans-expr.cc | 2 +- gcc/testsuite/gfortran.dg/finalize_61.f90 | 96 +++++++++++++++++++++++++++++++ 4 files changed, 101 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 46b5c0f77260..e207b0c06d35 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11455,12 +11455,12 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, tree gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, - int caf_mode) + int caf_mode, bool no_finalization) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, DEALLOCATE_ALLOC_COMP, GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, - NULL); + NULL, no_finalization); } tree diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 8304a6af0f39..4b51e546904b 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -53,7 +53,8 @@ bool gfc_caf_is_dealloc_only (int); tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0); -tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0); +tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0, + bool no_finalization = false); tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree, tree, tree, tree); tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int, diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index fc82ac11234a..33adff6b9195 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -8191,7 +8191,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) || e->ts.type == BT_DERIVED) tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, - parm_rank); + parm_rank, 0, true); else if (e->ts.type == BT_CLASS) tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived, tmp, parm_rank); diff --git a/gcc/testsuite/gfortran.dg/finalize_61.f90 b/gcc/testsuite/gfortran.dg/finalize_61.f90 new file mode 100644 index 000000000000..bb3d58be33ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalize_61.f90 @@ -0,0 +1,96 @@ +! { dg-run } +! +! Test the fix for PR123483. The 'resourceManagerDestructor' was called once too often, with +! conditions shown in the comments below. +! +! Contributed by Andrew Benson <[email protected]> +! +module rm + + type :: resourceManager + integer, pointer :: counter => null() + contains + final :: resourceManagerDestructor + procedure :: resourceManagerAssign + generic :: assignment(=) => resourceManagerAssign + end type resourceManager + + interface resourceManager + module procedure resourceManagerConstructor + end interface resourceManager + + type :: base + contains + procedure :: baseAssignment + generic :: assignment(=) => baseAssignment ! CONDITION: defined assignment triggered the bug. + end type base + + type, extends(base) :: worker ! CONDITION: type being extension of another type triggered the bug... + integer, allocatable, dimension(:) :: x ! ...together with this allocatable array. + type(resourceManager) :: workspaceManager + end type worker + + interface worker + module procedure workConstructor + end interface worker + +contains + + function resourceManagerConstructor() result(self) + type(resourceManager) :: self + allocate(self%counter) + self%counter=1 + return + end function resourceManagerConstructor + + subroutine resourceManagerDestructor(self) + implicit none + type(resourceManager), intent(inout) :: self + if (associated(self%counter)) then + if (self%counter == 1) stop 1 + self%counter=self%counter-1 + if (self%counter == 0) deallocate(self%counter) + end if + return + end subroutine resourceManagerDestructor + + subroutine resourceManagerAssign(to,from) + implicit none + class(resourceManager), intent(out) :: to + class(resourceManager), intent(in) :: from + if (associated(from%counter)) then + to%counter => from%counter + to%counter=to%counter+1 + else + to%counter => null() + end if + return + end subroutine resourceManagerAssign + + subroutine baseAssignment(self,from) + class(base), intent(out) :: self + class(base), intent(in) :: from + select type (self) + type is (worker) + select type (from) + type is (worker) + self%workspaceManager=from%workspaceManager + end select + end select + end subroutine baseAssignment + + function workConstructor() result(self) + type(worker) :: self + self%workspaceManager=resourceManager() + end function workConstructor + +end module rm + +program duplicateFinalizationBug + use rm + type(worker) :: a + + a=worker() + if (.not.associated (a%workspacemanager%counter) .or. & + a%workspacemanager%counter .ne. 1) stop 2 +end program duplicateFinalizationBug
