Peter Klausler 37180ed743
[flang] Turn "error" cases into warning for "indistinguishable" specific procedures (#79621)
When a generic procedure interface, either declared or the result of
    merging two use-associated generics, has two specific procedures
    that are not distinguishable according to the rules in F'2023
    subclause 15.4.3.4.5, emit a portability warning rather than a
    hard error message.  The rules in that subclause are not adequate
    to detect pairs of specific procedures that admit an ambiguous
    reference, as demonstrated by a case that arose in pFUnit.  Further,
    these distinguishability checks, even if sufficient to the task
    of detecting pairs of specifics capable of ambiguous references,
    should only apply to pairs where *every* reference would have to
    be ambiguous -- and this can and is validated at every reference
    anyway.  Last, only XLF enforces these incomplete and needless
    distinguishability rules -- every other compiler seems to just
    check that each procedure reference resolves to exactly one
    specific procedure.
    
    If the standard were to complete lose subclause 15.4.3.4.5 and
    its related note (C.11.6) -- which admits that the rules are
    incomplete! -- and simply require that each generic procedure
    reference resolve unambiguously to exactly one specific, nobody
    would miss them.  This patch changes this compiler to give them
    lip service when requested, but they are now otherwise ignored.
2024-01-29 14:36:37 -08:00

380 lines
10 KiB
Fortran

! RUN: %python %S/test_errors.py %s %flang_fc1
! Invalid operand types when user-defined operator is available
module m1
type :: t
end type
interface operator(==)
logical function eq_tt(x, y)
import :: t
type(t), intent(in) :: x, y
end
end interface
interface operator(+)
logical function add_tr(x, y)
import :: t
type(t), intent(in) :: x
real, intent(in) :: y
end
logical function plus_t(x)
import :: t
type(t), intent(in) :: x
end
logical function add_12(x, y)
real, intent(in) :: x(:), y(:,:)
end
end interface
interface operator(.and.)
logical function and_tr(x, y)
import :: t
type(t), intent(in) :: x
real, intent(in) :: y
end
end interface
interface operator(//)
logical function concat_tt(x, y)
import :: t
type(t), intent(in) :: x, y
end
end interface
interface operator(.not.)
logical function not_r(x)
real, intent(in) :: x
end
end interface
type(t) :: x, y
real :: r
logical :: l
integer :: iVar
complex :: cvar
character :: charVar
contains
subroutine test_relational()
l = x == y !OK
l = x .eq. y !OK
l = x .eq. y !OK
l = iVar == z'fe' !OK
l = z'fe' == iVar !OK
l = r == z'fe' !OK
l = z'fe' == r !OK
l = cVar == z'fe' !OK
l = z'fe' == cVar !OK
!ERROR: Operands of .EQ. must have comparable types; have CHARACTER(KIND=1) and INTEGER(4)
l = charVar == z'fe'
!ERROR: Operands of .EQ. must have comparable types; have INTEGER(4) and CHARACTER(KIND=1)
l = z'fe' == charVar
!ERROR: Operands of .EQ. must have comparable types; have LOGICAL(4) and INTEGER(4)
l = l == z'fe'
!ERROR: Operands of .EQ. must have comparable types; have INTEGER(4) and LOGICAL(4)
l = z'fe' == l
!ERROR: Operands of .EQ. must have comparable types; have TYPE(t) and REAL(4)
l = x == r
lVar = z'a' == b'1010' !OK
end
subroutine test_numeric()
l = x + r !OK
!ERROR: No intrinsic or user-defined OPERATOR(+) matches operand types REAL(4) and TYPE(t)
l = r + x
end
subroutine test_logical()
l = x .and. r !OK
!ERROR: No intrinsic or user-defined OPERATOR(.AND.) matches operand types REAL(4) and TYPE(t)
l = r .and. x
end
subroutine test_unary()
l = +x !OK
!ERROR: No intrinsic or user-defined OPERATOR(+) matches operand type LOGICAL(4)
l = +l
l = .not. r !OK
!ERROR: No intrinsic or user-defined OPERATOR(.NOT.) matches operand type TYPE(t)
l = .not. x
end
subroutine test_concat()
l = x // y !OK
!ERROR: No intrinsic or user-defined OPERATOR(//) matches operand types TYPE(t) and REAL(4)
l = x // r
end
subroutine test_conformability(x, y)
real :: x(10), y(10,10)
l = x + y !OK
!ERROR: No intrinsic or user-defined OPERATOR(+) matches rank 2 array of REAL(4) and rank 1 array of REAL(4)
l = y + x
end
end
! Invalid operand types when user-defined operator is not available
module m2
intrinsic :: sin
type :: t
end type
type(t) :: x, y
real :: r
logical :: l
contains
subroutine test_relational()
!ERROR: Operands of .EQ. must have comparable types; have TYPE(t) and REAL(4)
l = x == r
!ERROR: Subroutine name is not allowed here
l = r == test_numeric
!ERROR: Function call must have argument list
l = r == sin
end
subroutine test_numeric()
!ERROR: Operands of + must be numeric; have REAL(4) and TYPE(t)
l = r + x
end
subroutine test_logical()
!ERROR: Operands of .AND. must be LOGICAL; have REAL(4) and TYPE(t)
l = r .and. x
end
subroutine test_unary()
!ERROR: Operand of unary + must be numeric; have LOGICAL(4)
l = +l
!ERROR: Operand of .NOT. must be LOGICAL; have TYPE(t)
l = .not. x
end
subroutine test_concat(a, b)
character(4,kind=1) :: a
character(4,kind=2) :: b
character(4) :: c
!ERROR: Operands of // must be CHARACTER with the same kind; have CHARACTER(KIND=1) and CHARACTER(KIND=2)
c = a // b
!ERROR: Operands of // must be CHARACTER with the same kind; have TYPE(t) and REAL(4)
l = x // r
end
subroutine test_conformability(x, y)
real :: x(10), y(10,10)
!ERROR: Operands of + are not conformable; have rank 2 and rank 1
l = y + x
end
end
! Invalid untyped operands: user-defined operator doesn't affect errors
module m3
interface operator(+)
logical function add(x, y)
logical, intent(in) :: x
integer, value :: y
end
end interface
contains
subroutine s1(x, y)
logical :: x
integer :: y
integer, pointer :: px
logical :: l
complex :: z
y = y + z'1' !OK
!ERROR: Operands of + must be numeric; have untyped and COMPLEX(4)
z = z'1' + z
y = +z'1' !OK
!ERROR: Operand of unary - must be numeric; have untyped
y = -z'1'
!ERROR: Operands of + must be numeric; have LOGICAL(4) and untyped
y = x + z'1'
!ERROR: A NULL() pointer is not allowed as an operand here
l = x /= null()
!ERROR: A NULL() pointer is not allowed as a relational operand
l = null(px) /= null(px)
!ERROR: A NULL() pointer is not allowed as an operand here
l = x /= null(px)
!ERROR: A NULL() pointer is not allowed as an operand here
l = px /= null()
!ERROR: A NULL() pointer is not allowed as a relational operand
l = px /= null(px)
!ERROR: A NULL() pointer is not allowed as an operand here
l = null() /= null()
end
end
! Test alternate operators. They aren't enabled by default so should be
! treated as defined operators, not intrinsic ones.
module m4
contains
subroutine s1(x, y, z)
logical :: x
real :: y, z
!ERROR: No operator .A. defined for REAL(4) and REAL(4)
x = y .a. z
!ERROR: No operator .O. defined for REAL(4) and REAL(4)
x = y .o. z
!ERROR: No operator .N. defined for REAL(4)
x = .n. y
!ERROR: No operator .XOR. defined for REAL(4) and REAL(4)
x = y .xor. z
!ERROR: No operator .X. defined for REAL(4)
x = .x. y
end
end
! Like m4 in resolve63 but compiled with different options.
! .A. is a defined operator.
module m5
interface operator(.A.)
logical function f1(x, y)
integer, intent(in) :: x, y
end
end interface
interface operator(.and.)
logical function f2(x, y)
real, intent(in) :: x, y
end
end interface
contains
subroutine s1(x, y, z)
logical :: x
complex :: y, z
!ERROR: No intrinsic or user-defined OPERATOR(.AND.) matches operand types COMPLEX(4) and COMPLEX(4)
x = y .and. z
!ERROR: No intrinsic or user-defined .A. matches operand types COMPLEX(4) and COMPLEX(4)
x = y .a. z
end
end
! Type-bound operators
module m6
type :: t1
contains
procedure, pass(x) :: p1 => f1
generic :: operator(+) => p1
end type
type, extends(t1) :: t2
contains
procedure, pass(y) :: p2 => f2
generic :: operator(+) => p2
end type
type :: t3
contains
procedure, nopass :: p1 => f1
!ERROR: OPERATOR(+) procedure 'p1' may not have NOPASS attribute
generic :: operator(+) => p1
end type
contains
integer function f1(x, y)
class(t1), intent(in) :: x
integer, intent(in) :: y
end
integer function f2(x, y)
class(t1), intent(in) :: x
class(t2), intent(in) :: y
end
subroutine test(x, y, z)
class(t1) :: x
class(t2) :: y
integer :: i
i = x + y
i = x + i
i = y + i
!ERROR: Operands of + must be numeric; have CLASS(t2) and CLASS(t1)
i = y + x
!ERROR: Operands of + must be numeric; have INTEGER(4) and CLASS(t1)
i = i + x
end
end
! Some cases where NULL is acceptable - ensure no false errors
module m7
implicit none
type :: t1
contains
procedure :: s1
generic :: operator(/) => s1
end type
interface operator(-)
module procedure s2
end interface
contains
integer function s1(x, y)
class(t1), intent(in) :: x
class(t1), intent(in), pointer :: y
s1 = 1
end
integer function s2(x, y)
type(t1), intent(in), pointer :: x, y
s2 = 2
end
subroutine test
integer :: j
type(t1), pointer :: x1
allocate(x1)
! These cases are fine.
j = x1 - x1
j = x1 - null(mold=x1)
j = null(mold=x1) - null(mold=x1)
j = null(mold=x1) - x1
j = x1 / x1
j = x1 / null(mold=x1)
j = null() - null(mold=x1)
j = null(mold=x1) - null()
j = null() - null()
!ERROR: A NULL() pointer is not allowed as an operand here
j = null() / null(mold=x1)
!ERROR: A NULL() pointer is not allowed as an operand here
j = null(mold=x1) / null()
!ERROR: A NULL() pointer is not allowed as an operand here
j = null() / null()
end
end
! 16.9.144(6)
module m8
interface generic
procedure s1, s2
end interface
contains
subroutine s1(ip1, rp1)
integer, pointer, intent(in) :: ip1
real, pointer, intent(in) :: rp1
end subroutine
subroutine s2(rp2, ip2)
real, pointer, intent(in) :: rp2
integer, pointer, intent(in) :: ip2
end subroutine
subroutine test
integer, pointer :: ip
real, pointer :: rp
call generic(ip, rp) ! ok
call generic(ip, null()) ! ok
call generic(rp, null()) ! ok
call generic(null(), rp) ! ok
call generic(null(), ip) ! ok
call generic(null(mold=ip), null()) ! ok
call generic(null(), null(mold=ip)) ! ok
!ERROR: The actual arguments to the generic procedure 'generic' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface
call generic(null(), null())
end subroutine
end
module m9
interface generic
procedure s1, s2
end interface
contains
subroutine s1(jf)
procedure(integer) :: jf
end subroutine
subroutine s2(af)
procedure(real) :: af
end subroutine
subroutine test
external underspecified
!ERROR: The actual arguments to the generic procedure 'generic' matched multiple specific procedures, perhaps due to use of NULL() without MOLD= or an actual procedure with an implicit interface
call generic(underspecified)
end subroutine
end module
! Ensure no bogus errors for assignments to CLASS(*) allocatable
module m10
type :: t1
integer :: n
end type
contains
subroutine test
class(*), allocatable :: poly
poly = 1
poly = 3.14159
poly = 'Il faut imaginer Sisyphe heureux'
poly = t1(1)
end subroutine
end module