1! { dg-do run }
2! { dg-options "-fcoarray=single" }
3!
4! PR fortran/37336
5!
6module 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
14contains
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
32end module m
33
34program 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
142contains
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
175end program
176