1! { dg-do run }
2! { dg-additional-options "-fdump-tree-original" }
3!
4! Test the fix for PR93963
5!
6
7module m
8contains
9function rank_p(this) result(rnk) bind(c)
10  use, intrinsic :: iso_c_binding, only: c_int
11
12  implicit none
13
14  integer(kind=c_int), pointer, intent(in) :: this(..)
15  integer(kind=c_int)                      :: rnk
16
17  select rank(this)
18  rank(0)
19    rnk = 0
20  rank(1)
21    rnk = 1
22  rank(2)
23    rnk = 2
24  rank(3)
25    rnk = 3
26  rank(4)
27    rnk = 4
28  rank(5)
29    rnk = 5
30  rank(6)
31    rnk = 6
32  rank(7)
33    rnk = 7
34  rank(8)
35    rnk = 8
36  rank(9)
37    rnk = 9
38  rank(10)
39    rnk = 10
40  rank(11)
41    rnk = 11
42  rank(12)
43    rnk = 12
44  rank(13)
45    rnk = 13
46  rank(14)
47    rnk = 14
48  rank(15)
49    rnk = 15
50  rank default
51    rnk = -1000
52  end select
53  return
54end function rank_p
55
56function rank_a(this) result(rnk) bind(c)
57  use, intrinsic :: iso_c_binding, only: c_int
58
59  implicit none
60
61  integer(kind=c_int), allocatable, intent(in) :: this(..)
62  integer(kind=c_int)                          :: rnk
63
64  select rank(this)
65  rank(0)
66    rnk = 0
67  rank(1)
68    rnk = 1
69  rank(2)
70    rnk = 2
71  rank(3)
72    rnk = 3
73  rank(4)
74    rnk = 4
75  rank(5)
76    rnk = 5
77  rank(6)
78    rnk = 6
79  rank(7)
80    rnk = 7
81  rank(8)
82    rnk = 8
83  rank(9)
84    rnk = 9
85  rank(10)
86    rnk = 10
87  rank(11)
88    rnk = 11
89  rank(12)
90    rnk = 12
91  rank(13)
92    rnk = 13
93  rank(14)
94    rnk = 14
95  rank(15)
96    rnk = 15
97  rank default
98    rnk = -1000
99  end select
100  return
101end function rank_a
102
103function rank_o(this) result(rnk) bind(c)
104  use, intrinsic :: iso_c_binding, only: c_int
105
106  implicit none
107
108  integer(kind=c_int), intent(in) :: this(..)
109  integer(kind=c_int)             :: rnk
110
111  select rank(this)
112  rank(0)
113    rnk = 0
114  rank(1)
115    rnk = 1
116  rank(2)
117    rnk = 2
118  rank(3)
119    rnk = 3
120  rank(4)
121    rnk = 4
122  rank(5)
123    rnk = 5
124  rank(6)
125    rnk = 6
126  rank(7)
127    rnk = 7
128  rank(8)
129    rnk = 8
130  rank(9)
131    rnk = 9
132  rank(10)
133    rnk = 10
134  rank(11)
135    rnk = 11
136  rank(12)
137    rnk = 12
138  rank(13)
139    rnk = 13
140  rank(14)
141    rnk = 14
142  rank(15)
143    rnk = 15
144  rank default
145    rnk = -1000
146  end select
147  return
148end function rank_o
149
150end module m
151
152program selr_p
153  use m
154  use, intrinsic :: iso_c_binding, only: c_int
155
156  implicit none
157
158  integer(kind=c_int), parameter :: siz = 7
159  integer(kind=c_int), parameter :: rnk = 1
160
161  integer(kind=c_int),     pointer :: intp(:)
162  integer(kind=c_int), allocatable :: inta(:)
163  integer(kind=c_int)              :: irnk
164
165  nullify(intp)
166  irnk = rank_p(intp)
167  if (irnk /= rnk)        stop 1
168  if (irnk /= rank(intp)) stop 2
169  !
170  irnk = rank_a(inta)
171  if (irnk /= rnk)        stop 3
172  if (irnk /= rank(inta)) stop 4
173  !
174  allocate(intp(siz))
175  irnk = rank_p(intp)
176  if (irnk /= rnk)        stop 5
177  if (irnk /= rank(intp)) stop 6
178  irnk = rank_o(intp)
179  if (irnk /= rnk)        stop 7
180  if (irnk /= rank(intp)) stop 8
181  deallocate(intp)
182  nullify(intp)
183  !
184  allocate(inta(siz))
185  irnk = rank_a(inta)
186  if (irnk /= rnk)        stop 9
187  if (irnk /= rank(inta)) stop 10
188  irnk = rank_o(inta)
189  if (irnk /= rnk)        stop 11
190  if (irnk /= rank(inta)) stop 12
191  deallocate(inta)
192
193end program selr_p
194
195! Special code for assumed rank - but only if not allocatable/pointer
196! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p
197! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } }
198