xref: /llvm-project/flang/test/Semantics/select-rank.f90 (revision cb1b846eda2b18955cad28742350e4a73f166c07) 
1! RUN: %python %S/test_errors.py %s %flang_fc1
2
3!Tests for SELECT RANK Construct(R1148)
4program select_rank
5   implicit none
6   integer, dimension(10:30, 10:20, -1:20) :: x
7   integer, parameter :: y(*) = [1,2,3,4]
8   integer, dimension(5) :: z
9   integer, allocatable :: a(:)
10
11   allocate(a(10:20))
12
13   call CALL_SHAPE(x)
14   call CALL_SHAPE(y)
15   call CALL_SHAPE(z)
16   call CALL_SHAPE(a)
17
18contains
19   !No error expected
20   subroutine CALL_ME(x)
21    implicit none
22    integer :: x(..)
23    SELECT RANK(x)
24    RANK (0)
25      print *, "PRINT RANK 0"
26    RANK (1)
27      print *, "PRINT RANK 1"
28    END SELECT
29   end
30
31   subroutine CALL_ME9(x)
32    implicit none
33    integer :: x(..),j
34    boo: SELECT RANK(x)
35    RANK (1+0)
36      print *, "PRINT RANK 1"
37      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == (1+0)))
38    END SELECT boo
39   end subroutine
40
41   !Error expected
42   subroutine CALL_ME2(x)
43    implicit none
44    integer :: x(..)
45    integer :: y(3),j
46    !ERROR: Selector 'y' is not an assumed-rank array variable
47    SELECT RANK(y)
48    RANK (0)
49      print *, "PRINT RANK 0"
50    RANK (1)
51      print *, "PRINT RANK 1"
52     END SELECT
53
54    SELECT RANK(x)
55    RANK(0)
56      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) ! will fail when RANK(x) is not zero here
57    END SELECT
58   end subroutine
59
60   subroutine CALL_ME3(x)
61    implicit none
62    integer :: x(..),j
63    SELECT RANK(x)
64    !ERROR: The value of the selector must be between zero and 15
65    RANK (16)
66      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 16))
67    END SELECT
68   end subroutine
69
70   subroutine CALL_ME4(x)
71    implicit none
72    integer :: x(..)
73    SELECT RANK(x)
74    RANK DEFAULT
75      print *, "ok "
76    !ERROR: Not more than one of the selectors of SELECT RANK statement may be DEFAULT
77    RANK DEFAULT
78      print *, "not ok"
79    RANK (3)
80      print *, "IT'S 3"
81    END SELECT
82   end subroutine
83
84   subroutine CALL_ME5(x)
85    implicit none
86    integer :: x(..),j
87    SELECT RANK(x)
88    RANK (0)
89      print *, "PRINT RANK 0"
90      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0))
91    RANK(1)
92      print *, "PRINT RANK 1"
93    !ERROR: Same rank value (0) not allowed more than once
94    RANK(0)
95      print *, "ERROR"
96      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0))
97    RANK(1+1)
98    !ERROR: Same rank value (2) not allowed more than once
99    RANK(1+1)
100    END SELECT
101   end subroutine
102
103   subroutine CALL_ME6(x)
104    implicit none
105    integer :: x(..),j
106    SELECT RANK(x)
107    RANK (3)
108      print *, "one"
109      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3))
110    !ERROR: The value of the selector must be between zero and 15
111    RANK(-1)
112      print *, "rank: negative"
113      !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
114      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == -1))
115    END SELECT
116   end subroutine
117
118   subroutine CALL_ME7(arg)
119   implicit none
120   integer :: i,j
121   integer, dimension(..), pointer :: arg
122   integer, pointer :: arg2
123   select RANK(arg)
124   !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
125   RANK (*)
126      print *, arg(1:1)
127   RANK (1)
128      print *, arg
129      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(arg) == 1))
130   end select
131
132   !ERROR: Selector 'arg2' is not an assumed-rank array variable
133   select RANK(arg2)
134   RANK (*)
135      print *,"This would lead to crash when saveSelSymbol has std::nullptr"
136   RANK (1)
137      print *, "Rank is 1"
138   end select
139
140   end subroutine
141
142   subroutine CALL_ME8(x)
143    implicit none
144    integer :: x(..),j
145    SELECT RANK(x)
146    Rank(2)
147      print *, "Now it's rank 2 "
148    RANK (*)
149      print *, "Going for another rank"
150      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
151    !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*'
152    RANK (*)
153      print *, "This is Wrong"
154    END SELECT
155   end subroutine
156
157   subroutine CALL_ME10(x)
158    implicit none
159    integer:: x(..), a=10,b=20,j
160    integer, dimension(5) :: arr = (/1,2,3,4,5/),brr
161    integer :: const_variable=10
162    integer, pointer :: ptr,nullptr=>NULL()
163    type derived
164         character(len = 50) :: title
165    end type derived
166    type(derived) :: obj1
167
168    SELECT RANK(x)
169    Rank(2)
170      print *, "Now it's rank 2 "
171    RANK (*)
172      print *, "Going for a other rank"
173    !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*'
174    RANK (*)
175      print *, "This is Wrong"
176    END SELECT
177
178    !ERROR: Selector 'brr' is not an assumed-rank array variable
179    SELECT RANK(ptr=>brr)
180    !ERROR: Must be a constant value
181    RANK(const_variable)
182      print *, "PRINT RANK 3"
183      !j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1))
184    !ERROR: Must be a constant value
185    RANK(nullptr)
186      print *, "PRINT RANK 3"
187    END SELECT
188
189    !ERROR: Selector 'x(1) + x(2)' is not an assumed-rank array variable
190    SELECT RANK (x(1) + x(2))
191
192    END SELECT
193
194    !ERROR: Selector 'x(1)' is not an assumed-rank array variable
195    SELECT RANK(x(1))
196
197    END SELECT
198
199    !ERROR: Selector 'x(1:2)' is not an assumed-rank array variable
200    SELECT RANK(x(1:2))
201
202    END SELECT
203
204    !ERROR: 'x' is not an object of derived type
205    SELECT RANK(x(1)%x(2))
206
207    END SELECT
208
209    !ERROR: Selector 'obj1%title' is not an assumed-rank array variable
210    SELECT RANK(obj1%title)
211
212    END SELECT
213
214    !ERROR: Selector 'arr(1:2)+ arr(4:5)' is not an assumed-rank array variable
215    SELECT RANK(arr(1:2)+ arr(4:5))
216
217    END SELECT
218
219    SELECT RANK(ptr=>x)
220    RANK (3)
221      PRINT *, "PRINT RANK 3"
222      !ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
223      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 0))
224    RANK (1)
225      PRINT *, "PRINT RANK 1"
226      j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1))
227    END SELECT
228   end subroutine
229   subroutine CALL_ME_TYPES(x)
230    implicit none
231    integer :: x(..),j
232    SELECT RANK(x)
233    !ERROR: Must have INTEGER type, but is LOGICAL(4)
234        RANK(.TRUE.)
235    !ERROR: Must have INTEGER type, but is REAL(4)
236        RANK(1.0)
237    !ERROR: Must be a constant value
238        RANK(RANK(x))
239    !ERROR: Must have INTEGER type, but is CHARACTER(KIND=1,LEN=6_8)
240        RANK("STRING")
241    END SELECT
242   end subroutine
243   subroutine CALL_SHAPE(x)
244    implicit none
245    integer :: x(..)
246    integer :: j
247    integer, pointer :: ptr
248    SELECT RANK(x)
249     RANK(1)
250       print *, "RANK 1"
251       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1))
252     RANK (3)
253       print *, "RANK 3"
254       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3))
255    END SELECT
256    SELECT RANK(ptr => x )
257     RANK(1)
258       print *, "RANK 1"
259       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1))
260     RANK (3)
261       print *, "RANK 3"
262       j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 3))
263    END SELECT
264
265   end subroutine
266
267end program
268