gcc/testsuite/gfortran.dg/finalize_40.f90

   1 ! { dg-do run }
   2 !
   3 ! Test that PR67471 is fixed. Used not to call the finalizer.
   4 !
   5 ! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
   6 !
   7 module test_final_mod
   8   implicit none
   9   type :: my_final
  10     integer :: n = 1
  11   contains
  12     final :: destroy_scalar, destroy_rank1_array
  13   end type my_final
  14   integer :: final_calls = 0
  15 contains
  16   subroutine destroy_rank1_array(self)
  17     type(my_final), intent(inout) :: self(:)
  18     if (size(self) /= 0) then
  19       if (size(self) /= 2) stop 1
  20       if (any (self%n /= [3,4])) stop 2
  21     else
  22       stop 3
  23     end if
  24     final_calls = final_calls + 1
  25   end subroutine destroy_rank1_array
  26
  27 ! Eliminate the warning about the lack of a scalar finalizer.
  28   subroutine destroy_scalar(self)
  29     type(my_final), intent(inout) :: self
  30     final_calls = final_calls + self%n
  31   end subroutine destroy_scalar
  32
  33 end module test_final_mod
  34
  35 program test_finalizer
  36   use test_final_mod
  37   implicit none
  38   type(my_final) :: b(4), c(2)
  39
  40   b%n = [2, 3, 4, 5]
  41   c%n = [6, 7]
  42   b(2:3) = c
  43   if (final_calls /= 1) stop 4
  44 end program test_finalizer