mirror of
https://github.com/llvm/llvm-project.git
synced 2025-04-17 16:16:39 +00:00
cb1b846eda
When a symbol is known to be a procedure due to its being referenced as a function or subroutine, improve the error messages that appear if the symbol is also used as an object by attaching the source location of its procedural use. Also, for errors spotted in name resolution due to how a given symbol has been used, don't unconditionally set the symbol's error flag (which is otherwise generally a good idea, to prevent cascades of errors), so that more unrelated errors related to usage will appear.
268 lines
6.7 KiB
Fortran
268 lines
6.7 KiB
Fortran
! RUN: %python %S/test_errors.py %s %flang_fc1
|
|
|
|
!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: negative"
|
|
!ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
|
|
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
|
|
select RANK(arg)
|
|
!ERROR: RANK (*) cannot be used when selector is POINTER or ALLOCATABLE
|
|
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 another 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"
|
|
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"
|
|
!ERROR: 'kind=' argument must be a constant scalar integer whose value is a supported kind for the intrinsic result type
|
|
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(KIND=1,LEN=6_8)
|
|
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
|