gcc/testsuite/gfortran.dg/finalize_48.f90

   1 ! { dg-do run }
   2 !
   3 ! Check that pr106576 is fixed. The temporary from the function result
   4 ! was not being finalized.
   5 !
   6 ! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
   7 !
   8 module y
   9   implicit none
  10   type foo
  11      integer :: n
  12    contains
  13      final :: cleanup
  14   end type foo
  15   interface assignment (=)
  16      module procedure assign
  17   end interface assignment (=)
  18   character(16) :: buffer(4)
  19   integer :: buffer_count = 1
  20 contains
  21
  22   subroutine assign (rop, op)
  23     type(foo), intent(inout) :: rop
  24     type(foo), intent(in) :: op
  25     rop%n = op%n + 1
  26     write (buffer(buffer_count), '(A12,I4)') "assign", rop%n
  27     buffer_count = buffer_count + 1
  28   end subroutine assign
  29
  30   function to_foo(n) result(res)
  31     integer, intent(in) :: n
  32     type (foo) :: res
  33     res%n = n
  34     write (buffer(buffer_count),  '(A12,I4)') "to_foo", res%n
  35     buffer_count = buffer_count + 1
  36   end function to_foo
  37
  38   subroutine cleanup (self)
  39     type (foo), intent(inout) :: self
  40     write (buffer(buffer_count),  '(A12,I4)') "cleanup", self%n
  41     buffer_count = buffer_count + 1
  42   end subroutine cleanup
  43 end module y
  44
  45 program memain
  46   use y
  47   implicit none
  48   character(16) :: check(4) = ["      to_foo   3", &
  49                                "      assign   4", &
  50                                "     cleanup   3", &
  51                                "     cleanup   4"]
  52   call chk
  53   if (any (buffer .ne. check)) stop 1
  54 contains
  55   subroutine chk
  56     type (foo) :: a
  57     a = to_foo(3)
  58   end subroutine chk
  59 end program memain