gcc/testsuite/gfortran.dg/finalize_39.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR67444 in which the finalization of a polymorphic 'var'
   4 ! was not being finalized before assignment. (STOP 3)
   5 !
   6 ! Contributed by Balint Aradi  <baladi@gmail.com>
   7 !
   8 module classes
   9   implicit none
  10   integer :: ivalue = 0
  11   integer :: icall = 0
  12   integer :: fvalue = 0
  13
  14   type :: Basic
  15     integer :: ii = -1
  16   contains
  17     procedure :: assignBasic
  18     generic :: assignment(=) => assignBasic
  19     final :: destructBasic
  20   end type Basic
  21   interface Basic
  22     module procedure initBasic
  23   end interface Basic
  24 contains
  25   function initBasic(initValue) result(this)
  26     integer, intent(in) :: initValue
  27     type(Basic) :: this
  28     this%ii = initValue
  29     icall = icall + 1
  30   end function initBasic
  31   subroutine assignBasic(this, other)
  32     class(Basic), intent(out) :: this
  33     type(Basic), intent(in) :: other
  34     this%ii = other%ii + 1
  35     icall = other%ii
  36   end subroutine assignBasic
  37   subroutine destructBasic(this)
  38     type(Basic), intent(inout) :: this
  39     fvalue = fvalue + 1
  40     select case (fvalue)
  41     case (1)
  42         if (this%ii /= -1) stop 1          ! First finalization before assignment to 'var'
  43         if (icall /= 1) stop 2             ! and before evaluation of 'expr'.
  44     case(2)
  45         if (this%ii /= ivalue) stop 3      ! Finalization of intent(out) in 'assignBasic'
  46         if (icall /= 42) stop 4            ! and after evaluation of 'expr'.
  47     case(3)
  48         if (this%ii /= ivalue + 1) stop 5  ! Finalization of 'expr' (function!) after assignment.
  49     case default
  50         stop 6                             ! Too many or no finalizations
  51     end select
  52   end subroutine destructBasic
  53 end module classes
  54
  55 module usage
  56   use classes
  57   implicit none
  58 contains
  59   subroutine useBasic()
  60     type(Basic) :: bas
  61     ivalue = 42
  62     bas = Basic(ivalue)
  63   end subroutine useBasic
  64 end module usage
  65
  66 program test
  67   use usage
  68   implicit none
  69   call useBasic()
  70   if (fvalue /= 3) stop 7                  ! 3 finalizations mandated.
  71 end program test