! RUN: %python %S/test_errors.py %s %flang_fc1
! Test for checking select type constraints,
module m1
use ISO_C_BINDING
type shape
integer :: color
logical :: filled
integer :: x
integer :: y
end type shape
type, extends(shape) :: rectangle
integer :: length
integer :: width
end type rectangle
type, extends(rectangle) :: square
end type square
type, extends(square) :: extsquare
end type
type :: unrelated
logical :: some_logical
end type
type withSequence
SEQUENCE
integer :: x
end type
type, BIND(C) :: withBind
INTEGER(c_int) ::int_in_c
end type
TYPE(shape), TARGET :: shape_obj
TYPE(rectangle), TARGET :: rect_obj
TYPE(square), TARGET :: squr_obj
!define polymorphic objects
class(*), pointer :: unlim_polymorphic
class(shape), pointer :: shape_lim_polymorphic
end
module m
type :: t(n)
integer, len :: n
end type
contains
subroutine CheckC1160( a )
class(*), intent(in) :: a
select type ( a )
!ERROR: The type specification statement must have LEN type parameter as assumed
type is ( character(len=10) ) !<-- assumed length-type
!ERROR: The type specification statement must have LEN type parameter as assumed
type is ( character )
! OK
type is ( character(len=*) )
!ERROR: The type specification statement must have LEN type parameter as assumed
type is ( t(n=10) )
! OK
type is ( t(n=*) ) !<-- assumed length-type
!ERROR: Derived type 'character' not found
class is ( character(len=10) ) !<-- assumed length-type
end select
end subroutine
subroutine s()
type derived(param)
integer, len :: param
class(*), allocatable :: x
end type
TYPE(derived(10)) :: a
select type (ax => a%x)
class is (derived(param=*))
print *, "hello"
end select
end subroutine s
end module
subroutine CheckC1157
use m1
integer, parameter :: const_var=10
!ERROR: Selector is not a named variable: 'associate-name =>' is required
select type(10)
end select
!ERROR: Selector is not a named variable: 'associate-name =>' is required
select type(const_var)
end select
!ERROR: Selector is not a named variable: 'associate-name =>' is required
select type (4.999)
end select
!ERROR: Selector is not a named variable: 'associate-name =>' is required
select type (shape_obj%x)
end select
end subroutine
!CheckPloymorphicSelectorType
subroutine CheckC1159a
integer :: int_variable
real :: real_variable
complex :: complex_var = cmplx(3.0, 4.0)
logical :: log_variable
character (len=10) :: char_variable = "OM"
!ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic
select type (int_variable)
end select
!ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic
select type (real_variable)
end select
!ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic
select type(complex_var)
end select
!ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic
select type(logical_variable)
end select
!ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic
select type(char_variable)
end select
end
subroutine CheckC1159b
integer :: x
!ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
select type (a => x)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is (integer)
print *,'integer ',a
end select
end
subroutine CheckC1159c
!ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
select type (a => x)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is (integer)
print *,'integer ',a
end select
end
subroutine s(arg)
class(*) :: arg
select type (arg)
type is (integer)
end select
end
subroutine CheckC1161
use m1
shape_lim_polymorphic => rect_obj
select type(shape_lim_polymorphic)
!ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
type is (withSequence)
!ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
type is (withBind)
end select
end
subroutine CheckC1162
use m1
class(rectangle), pointer :: rectangle_polymorphic
!not unlimited polymorphic objects
select type (rectangle_polymorphic)
!ERROR: Type specification 'shape' must be an extension of TYPE 'rectangle'
type is (shape)
!ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
type is (unrelated)
!all are ok
type is (square)
type is (extsquare)
!Handle same types
type is (rectangle)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is(integer)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is(real)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is(logical)
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is(character(len=*))
!ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
type is(complex)
end select
!Unlimited polymorphic objects are allowed.
unlim_polymorphic => rect_obj
select type (unlim_polymorphic)
type is (shape)
type is (unrelated)
end select
end
module c1162a
type pdt(kind,len)
integer, kind :: kind
integer, len :: len
end type
contains
subroutine foo(x)
class(pdt(kind=1,len=:)), allocatable :: x
select type (x)
type is (pdt(kind=1, len=*))
!ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
type is (pdt(kind=2, len=*))
!ERROR: Value of KIND type parameter 'kind' must be constant
!ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
type is (pdt(kind=*, len=*))
end select
end subroutine
end module
subroutine CheckC1163
use m1
!assign dynamically
shape_lim_polymorphic => rect_obj
unlim_polymorphic => shape_obj
select type (shape_lim_polymorphic)
type is (shape)
!ERROR: Type specification 'shape' conflicts with previous type specification
type is (shape)
class is (square)
!ERROR: Type specification 'square' conflicts with previous type specification
class is (square)
end select
select type (unlim_polymorphic)
type is (INTEGER(4))
type is (shape)
!ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
type is (INTEGER(4))
end select
end
subroutine CheckC1164
use m1
shape_lim_polymorphic => rect_obj
unlim_polymorphic => shape_obj
select type (shape_lim_polymorphic)
CLASS DEFAULT
!ERROR: Type specification 'DEFAULT' conflicts with previous type specification
CLASS DEFAULT
TYPE IS (shape)
TYPE IS (rectangle)
!ERROR: Type specification 'DEFAULT' conflicts with previous type specification
CLASS DEFAULT
end select
!Saving computation if some error in guard by not computing RepeatingCases
select type (shape_lim_polymorphic)
CLASS DEFAULT
CLASS DEFAULT
!ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
TYPE IS(withSequence)
end select
end subroutine
subroutine WorkingPolymorphism
use m1
!assign dynamically
shape_lim_polymorphic => rect_obj
unlim_polymorphic => shape_obj
select type (shape_lim_polymorphic)
type is (shape)
print *, "hello shape"
type is (rectangle)
print *, "hello rect"
type is (square)
print *, "hello square"
CLASS DEFAULT
print *, "default"
end select
print *, "unlim polymorphism"
select type (unlim_polymorphic)
type is (shape)
print *, "hello shape"
type is (rectangle)
print *, "hello rect"
type is (square)
print *, "hello square"
CLASS DEFAULT
print *, "default"
end select
end
subroutine CheckNotProcedure
use m1
!ERROR: Selector may not be a procedure
select type (x=>f)
end select
contains
function f() result(res)
class(shape), allocatable :: res
end
subroutine CheckAssumedRankInSelectType(var)
class(*), intent(in) :: var(..)
!ERROR: Assumed-rank variable may only be used as actual argument
select type(var)
end select
end
end
Codebase Browser
llvm