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

diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 3221bef09bb094cfca64c5eecb9ba6909b0b7bbd..dc74819cced5fcbc458094dbafb0d46304eadf6c 100644 (file)
--- 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 (file)
index 0000000..9dd4fa0
--- /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