| ! RUN: %S/test_errors.sh %s %t %f18 |
| |
| !Tests for SELECT RANK Construct(R1148) |
| program select_rank |
| implicit none |
| integer, dimension(10:30, 10:20, -1:20) :: x |
| integer, parameter :: y(*) = [1,2,3,4] |
| integer, dimension(5) :: z |
| integer, allocatable :: a(:) |
| |
| allocate(a(10:20)) |
| |
| call CALL_SHAPE(x) |
| call CALL_SHAPE(y) |
| call CALL_SHAPE(z) |
| call CALL_SHAPE(a) |
| |
| contains |
| !No error expected |
| subroutine CALL_ME(x) |
| implicit none |
| integer :: x(..) |
| SELECT RANK(x) |
| RANK (0) |
| print *, "PRINT RANK 0" |
| RANK (1) |
| print *, "PRINT RANK 1" |
| END SELECT |
| end |
| |
| subroutine CALL_ME9(x) |
| implicit none |
| integer :: x(..),j |
| boo: SELECT RANK(x) |
| RANK (1+0) |
| print *, "PRINT RANK 1" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == (1+0))) |
| END SELECT boo |
| end subroutine |
| |
| !Error expected |
| subroutine CALL_ME2(x) |
| implicit none |
| integer :: x(..) |
| integer :: y(3),j |
| !ERROR: Selector 'y' is not an assumed-rank array variable |
| SELECT RANK(y) |
| RANK (0) |
| print *, "PRINT RANK 0" |
| RANK (1) |
| print *, "PRINT RANK 1" |
| END SELECT |
| |
| SELECT RANK(x) |
| RANK(0) |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) ! will fail when RANK(x) is not zero here |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME3(x) |
| implicit none |
| integer :: x(..),j |
| SELECT RANK(x) |
| !ERROR: The value of the selector must be between zero and 15 |
| RANK (16) |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 16)) |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME4(x) |
| implicit none |
| integer :: x(..) |
| SELECT RANK(x) |
| RANK DEFAULT |
| print *, "ok " |
| !ERROR: Not more than one of the selectors of SELECT RANK statement may be DEFAULT |
| RANK DEFAULT |
| print *, "not ok" |
| RANK (3) |
| print *, "IT'S 3" |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME5(x) |
| implicit none |
| integer :: x(..),j |
| SELECT RANK(x) |
| RANK (0) |
| print *, "PRINT RANK 0" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) |
| RANK(1) |
| print *, "PRINT RANK 1" |
| !ERROR: Same rank value (0) not allowed more than once |
| RANK(0) |
| print *, "ERROR" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 0)) |
| RANK(1+1) |
| !ERROR: Same rank value (2) not allowed more than once |
| RANK(1+1) |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME6(x) |
| implicit none |
| integer :: x(..),j |
| SELECT RANK(x) |
| RANK (3) |
| print *, "one" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3)) |
| !ERROR: The value of the selector must be between zero and 15 |
| RANK(-1) |
| print *, "rank: -ve" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == -1)) |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME7(arg) |
| implicit none |
| integer :: i,j |
| integer, dimension(..), pointer :: arg |
| integer, pointer :: arg2 |
| !ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE |
| select RANK(arg) |
| RANK (*) |
| print *, arg(1:1) |
| RANK (1) |
| print *, arg |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(arg) == 1)) |
| end select |
| |
| !ERROR: Selector 'arg2' is not an assumed-rank array variable |
| select RANK(arg2) |
| RANK (*) |
| print *,"This would lead to crash when saveSelSymbol has std::nullptr" |
| RANK (1) |
| print *, "Rank is 1" |
| end select |
| |
| end subroutine |
| |
| subroutine CALL_ME8(x) |
| implicit none |
| integer :: x(..),j |
| SELECT RANK(x) |
| Rank(2) |
| print *, "Now it's rank 2 " |
| RANK (*) |
| print *, "Going for a other rank" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) |
| !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*' |
| RANK (*) |
| print *, "This is Wrong" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) |
| END SELECT |
| end subroutine |
| |
| subroutine CALL_ME10(x) |
| implicit none |
| integer:: x(..), a=10,b=20,j |
| integer, dimension(5) :: arr = (/1,2,3,4,5/),brr |
| integer :: const_variable=10 |
| integer, pointer :: ptr,nullptr=>NULL() |
| type derived |
| character(len = 50) :: title |
| end type derived |
| type(derived) :: obj1 |
| |
| SELECT RANK(x) |
| Rank(2) |
| print *, "Now it's rank 2 " |
| RANK (*) |
| print *, "Going for a other rank" |
| !ERROR: Not more than one of the selectors of SELECT RANK statement may be '*' |
| RANK (*) |
| print *, "This is Wrong" |
| END SELECT |
| |
| !ERROR: Selector 'brr' is not an assumed-rank array variable |
| SELECT RANK(ptr=>brr) |
| !ERROR: Must be a constant value |
| RANK(const_variable) |
| print *, "PRINT RANK 3" |
| !j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) |
| !ERROR: Must be a constant value |
| RANK(nullptr) |
| print *, "PRINT RANK 3" |
| END SELECT |
| |
| !ERROR: Selector 'x(1) + x(2)' is not an assumed-rank array variable |
| SELECT RANK (x(1) + x(2)) |
| |
| END SELECT |
| |
| !ERROR: Selector 'x(1)' is not an assumed-rank array variable |
| SELECT RANK(x(1)) |
| |
| END SELECT |
| |
| !ERROR: Selector 'x(1:2)' is not an assumed-rank array variable |
| SELECT RANK(x(1:2)) |
| |
| END SELECT |
| |
| !ERROR: 'x' is not an object of derived type |
| SELECT RANK(x(1)%x(2)) |
| |
| END SELECT |
| |
| !ERROR: Selector 'obj1%title' is not an assumed-rank array variable |
| SELECT RANK(obj1%title) |
| |
| END SELECT |
| |
| !ERROR: Selector 'arr(1:2)+ arr(4:5)' is not an assumed-rank array variable |
| SELECT RANK(arr(1:2)+ arr(4:5)) |
| |
| END SELECT |
| |
| SELECT RANK(ptr=>x) |
| RANK (3) |
| PRINT *, "PRINT RANK 3" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 0)) |
| RANK (1) |
| PRINT *, "PRINT RANK 1" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) |
| END SELECT |
| end subroutine |
| subroutine CALL_ME_TYPES(x) |
| implicit none |
| integer :: x(..),j |
| SELECT RANK(x) |
| !ERROR: Must have INTEGER type, but is LOGICAL(4) |
| RANK(.TRUE.) |
| !ERROR: Must have INTEGER type, but is REAL(4) |
| RANK(1.0) |
| !ERROR: Must be a constant value |
| RANK(RANK(x)) |
| !ERROR: Must have INTEGER type, but is CHARACTER(1) |
| RANK("STRING") |
| END SELECT |
| end subroutine |
| subroutine CALL_SHAPE(x) |
| implicit none |
| integer :: x(..) |
| integer :: j |
| integer, pointer :: ptr |
| SELECT RANK(x) |
| RANK(1) |
| print *, "RANK 1" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 1)) |
| RANK (3) |
| print *, "RANK 3" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(x) == 3)) |
| END SELECT |
| SELECT RANK(ptr => x ) |
| RANK(1) |
| print *, "RANK 1" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 1)) |
| RANK (3) |
| print *, "RANK 3" |
| j = INT(0, KIND=MERGE(KIND(0), -1, RANK(ptr) == 3)) |
| END SELECT |
| |
| end subroutine |
| |
| end program |