From: Jerry DeLisle Date: Fri, 9 Jan 2026 17:38:52 +0000 (-0800) Subject: Fortran: [PR123483] Fix duplicate finalization X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=b405a04ffde07e9a3021b74a5d40c7938984b88f;p=thirdparty%2Fgcc.git 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 --- diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 46b5c0f7726..e207b0c06d3 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 8304a6af0f3..4b51e546904 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 fc82ac11234..33adff6b919 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 00000000000..bb3d58be33e --- /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 +! +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