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 <abensonca@gcc.gnu.org>

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 46b5c0f7726088dd172a55ccdf0d60438b0810b0..e207b0c06d356c50e40685148de7a2a47089d361 100644 (file)
--- 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 8304a6af0f3948e9d9d9973a6b7192f79b98d187..4b51e546904b7a03ff6acadbf48584c117b414c5 100644 (file)
--- 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 fc82ac11234a2797e37b114c3cec29aa64fd5b45..33adff6b9195b770d1ff8346afdc46a372d23927 100644 (file)
--- 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 (file)
index 0000000..bb3d58b
--- /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  <abensonca@gmail.com>
+!
+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