gcc/testsuite/gfortran.dg/finalize_12.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcoarray=single" }
   3 !
   4 ! PR fortran/37336
   5 !
   6 module m
   7   implicit none
   8   type t
   9     integer :: i
  10   contains
  11     final :: fini, fini2
  12   end type t
  13   integer :: global_count1, global_count2
  14 contains
  15   subroutine fini(x)
  16     type(t) :: x
  17     !print *, 'fini:',x%i
  18     if (global_count1 == -1) STOP 1
  19     if (x%i /= 42) STOP 2
  20     x%i = 33
  21     global_count1 = global_count1 + 1
  22   end subroutine fini
  23   subroutine fini2(x)
  24     type(t) :: x(:)
  25     !print *, 'fini2', x%i
  26     if (global_count2 == -1) STOP 3
  27     if (size(x) /= 5) STOP 4
  28     if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) STOP 5
  29     x%i = 33
  30     global_count2 = global_count2 + 10
  31   end subroutine fini2
  32 end module m
  33
  34 program pp
  35   use m
  36   implicit none
  37   type(t), allocatable :: ya
  38   class(t), allocatable :: yc
  39   type(t), allocatable :: yaa(:)
  40   class(t), allocatable :: yca(:)
  41
  42   type(t), allocatable :: ca[:]
  43   class(t), allocatable :: cc[:]
  44   type(t), allocatable :: caa(:)[:]
  45   class(t), allocatable :: cca(:)[:]
  46
  47   global_count1 = -1
  48   global_count2 = -1
  49   allocate (ya, yc, yaa(5), yca(5))
  50   global_count1 = 0
  51   global_count2 = 0
  52   ya%i = 42
  53   yc%i = 42
  54   yaa%i = [1,2,3,4,5]
  55   yca%i = [1,2,3,4,5]
  56
  57   call foo(ya, yc, yaa, yca)
  58   if (global_count1 /= 2) STOP 6
  59   if (global_count2 /= 20) STOP 7
  60
  61   ! Coarray finalization
  62   allocate (ca[*], cc[*], caa(5)[*], cca(5)[*])
  63   global_count1 = 0
  64   global_count2 = 0
  65   ca%i = 42
  66   cc%i = 42
  67   caa%i = [1,2,3,4,5]
  68   cca%i = [1,2,3,4,5]
  69   deallocate (ca, cc, caa, cca)
  70   if (global_count1 /= 2) STOP 8
  71   if (global_count2 /= 20) STOP 9
  72   global_count1 = -1
  73   global_count2 = -1
  74
  75   block
  76     type(t), allocatable :: za
  77     class(t), allocatable :: zc
  78     type(t), allocatable :: zaa(:)
  79     class(t), allocatable :: zca(:)
  80
  81     ! Test intent(out) finalization
  82     allocate (za, zc, zaa(5), zca(5))
  83     global_count1 = 0
  84     global_count2 = 0
  85     za%i = 42
  86     zc%i = 42
  87     zaa%i = [1,2,3,4,5]
  88     zca%i = [1,2,3,4,5]
  89
  90     call foo(za, zc, zaa, zca)
  91     if (global_count1 /= 2) STOP 10
  92     if (global_count2 /= 20) STOP 11
  93
  94     ! Test intent(out) finalization with optional
  95     call foo_opt()
  96     call opt()
  97
  98     ! Test intent(out) finalization with optional
  99     allocate (za, zc, zaa(5), zca(5))
 100     global_count1 = 0
 101     global_count2 = 0
 102     za%i = 42
 103     zc%i = 42
 104     zaa%i = [1,2,3,4,5]
 105     zca%i = [1,2,3,4,5]
 106
 107     call foo_opt(za, zc, zaa, zca)
 108     if (global_count1 /= 2) STOP 12
 109     if (global_count2 /= 20) STOP 13
 110
 111     ! Test DEALLOCATE finalization
 112     allocate (za, zc, zaa(5), zca(5))
 113     global_count1 = 0
 114     global_count2 = 0
 115     za%i = 42
 116     zc%i = 42
 117     zaa%i = [1,2,3,4,5]
 118     zca%i = [6,7,8,9,10]
 119     deallocate (za, zc, zaa, zca)
 120     if (global_count1 /= 2) STOP 14
 121     if (global_count2 /= 20) STOP 15
 122
 123     ! Test end-of-scope finalization
 124     allocate (za, zc, zaa(5), zca(5))
 125     global_count1 = 0
 126     global_count2 = 0
 127     za%i = 42
 128     zc%i = 42
 129     zaa%i = [1,2,3,4,5]
 130     zca%i = [6,7,8,9,10]
 131   end block
 132
 133   if (global_count1 /= 2) STOP 16
 134   if (global_count2 /= 20) STOP 17
 135
 136   ! Test that no end-of-scope finalization occurs
 137   ! for SAVED variable in main
 138   allocate (ya, yc, yaa(5), yca(5))
 139   global_count1 = -1
 140   global_count2 = -1
 141
 142 contains
 143
 144   subroutine opt(xa, xc, xaa, xca)
 145     type(t),  allocatable, optional :: xa
 146     class(t), allocatable, optional :: xc
 147     type(t),  allocatable, optional :: xaa(:)
 148     class(t), allocatable, optional :: xca(:)
 149     call foo_opt(xc, xc, xaa)
 150     !call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445
 151   end subroutine opt
 152   subroutine foo_opt(xa, xc, xaa, xca)
 153     type(t),  allocatable, intent(out), optional :: xa
 154     class(t), allocatable, intent(out), optional :: xc
 155     type(t),  allocatable, intent(out), optional :: xaa(:)
 156     class(t), allocatable, intent(out), optional :: xca(:)
 157
 158     if (.not. present(xa)) &
 159       return
 160     if (allocated (xa)) STOP 18
 161     if (allocated (xc)) STOP 19
 162     if (allocated (xaa)) STOP 20
 163     if (allocated (xca)) STOP 21
 164   end subroutine foo_opt
 165   subroutine foo(xa, xc, xaa, xca)
 166     type(t),  allocatable, intent(out) :: xa
 167     class(t), allocatable, intent(out) :: xc
 168     type(t),  allocatable, intent(out) :: xaa(:)
 169     class(t), allocatable, intent(out) :: xca(:)
 170     if (allocated (xa)) STOP 22
 171     if (allocated (xc)) STOP 23
 172     if (allocated (xaa)) STOP 24
 173     if (allocated (xca)) STOP 25
 174   end subroutine foo
 175 end program