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) call abort ()
  19     if (x%i /= 42) call abort()
  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) call abort ()
  27     if (size(x) /= 5) call abort()
  28     if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) call abort()
  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) call abort ()
  59   if (global_count2 /= 20) call abort ()
  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) call abort ()
  71   if (global_count2 /= 20) call abort ()
  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) call abort ()
  92     if (global_count2 /= 20) call abort ()
  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) call abort ()
 109     if (global_count2 /= 20) call abort ()
 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) call abort ()
 121     if (global_count2 /= 20) call abort ()
 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) call abort ()
 134   if (global_count2 /= 20) call abort ()
 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)) call abort ()
 161     if (allocated (xc)) call abort ()
 162     if (allocated (xaa)) call abort ()
 163     if (allocated (xca)) call abort ()
 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)) call abort ()
 171     if (allocated (xc)) call abort ()
 172     if (allocated (xaa)) call abort ()
 173     if (allocated (xca)) call abort ()
 174   end subroutine foo
 175 end program