flang/test/Semantics/select-rank.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2
   3 !Tests for SELECT RANK Construct(R1148)
   4 program 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
  18 contains
  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
 267 end program