flang/test/Semantics/selecttype01.f90

   1 ! RUN: %python %S/test_errors.py %s %flang_fc1
   2 ! Test for checking select type constraints,
   3 module m1
   4   use ISO_C_BINDING
   5   type shape
   6     integer :: color
   7     logical :: filled
   8     integer :: x
   9     integer :: y
  10   end type shape
  11
  12   type, extends(shape) :: rectangle
  13     integer :: length
  14     integer :: width
  15   end type rectangle
  16
  17   type, extends(rectangle) :: square
  18   end type square
  19
  20   type, extends(square) :: extsquare
  21   end type
  22
  23   type :: unrelated
  24     logical :: some_logical
  25   end type
  26
  27   type withSequence
  28     SEQUENCE
  29     integer :: x
  30   end type
  31
  32   type, BIND(C) :: withBind
  33     INTEGER(c_int) ::int_in_c
  34   end type
  35
  36   TYPE(shape), TARGET :: shape_obj
  37   TYPE(rectangle), TARGET :: rect_obj
  38   TYPE(square), TARGET :: squr_obj
  39   !define polymorphic objects
  40   class(*), pointer :: unlim_polymorphic
  41   class(shape), pointer :: shape_lim_polymorphic
  42 end
  43 module m
  44   type :: t(n)
  45     integer, len :: n
  46   end type
  47 contains
  48   subroutine CheckC1160( a )
  49     class(*), intent(in) :: a
  50     select type ( a )
  51       !ERROR: The type specification statement must have LEN type parameter as assumed
  52       type is ( character(len=10) ) !<-- assumed length-type
  53       !ERROR: The type specification statement must have LEN type parameter as assumed
  54       type is ( character )
  55       ! OK
  56       type is ( character(len=*) )
  57       !ERROR: The type specification statement must have LEN type parameter as assumed
  58       type is ( t(n=10) )
  59       ! OK
  60       type is ( t(n=*) )   !<-- assumed length-type
  61       !ERROR: Derived type 'character' not found
  62       class is ( character(len=10) ) !<-- assumed length-type
  63     end select
  64   end subroutine
  65
  66   subroutine s()
  67     type derived(param)
  68       integer, len :: param
  69       class(*), allocatable :: x
  70     end type
  71     TYPE(derived(10)) :: a
  72     select type (ax => a%x)
  73       class is (derived(param=*))
  74         print *, "hello"
  75     end select
  76   end subroutine s
  77 end module
  78
  79 subroutine CheckC1157
  80   use m1
  81   integer, parameter :: const_var=10
  82   !ERROR: Selector is not a named variable: 'associate-name =>' is required
  83   select type(10)
  84   end select
  85   !ERROR: Selector is not a named variable: 'associate-name =>' is required
  86   select type(const_var)
  87   end select
  88   !ERROR: Selector is not a named variable: 'associate-name =>' is required
  89   select type (4.999)
  90   end select
  91   !ERROR: Selector is not a named variable: 'associate-name =>' is required
  92   select type (shape_obj%x)
  93   end select
  94 end subroutine
  95
  96 !CheckPloymorphicSelectorType
  97 subroutine CheckC1159a
  98   integer :: int_variable
  99   real :: real_variable
 100   complex :: complex_var = cmplx(3.0, 4.0)
 101   logical :: log_variable
 102   character (len=10) :: char_variable = "OM"
 103   !ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic
 104   select type (int_variable)
 105   end select
 106   !ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic
 107   select type (real_variable)
 108   end select
 109   !ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic
 110   select type(complex_var)
 111   end select
 112   !ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic
 113   select type(logical_variable)
 114   end select
 115   !ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic
 116   select type(char_variable)
 117   end select
 118 end
 119
 120 subroutine CheckC1159b
 121   integer :: x
 122   !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
 123   select type (a => x)
 124   !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 125   type is (integer)
 126     print *,'integer ',a
 127   end select
 128 end
 129
 130 subroutine CheckC1159c
 131   !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic
 132   select type (a => x)
 133   !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 134   type is (integer)
 135     print *,'integer ',a
 136   end select
 137 end
 138
 139 subroutine s(arg)
 140   class(*) :: arg
 141     select type (arg)
 142         type is (integer)
 143     end select
 144 end
 145
 146 subroutine CheckC1161
 147   use m1
 148   shape_lim_polymorphic => rect_obj
 149   select type(shape_lim_polymorphic)
 150     !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
 151     type is (withSequence)
 152     !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
 153     type is (withBind)
 154   end select
 155 end
 156
 157 subroutine CheckC1162
 158   use m1
 159   class(rectangle), pointer :: rectangle_polymorphic
 160   !not unlimited polymorphic objects
 161   select type (rectangle_polymorphic)
 162     !ERROR: Type specification 'shape' must be an extension of TYPE 'rectangle'
 163     type is (shape)
 164     !ERROR: Type specification 'unrelated' must be an extension of TYPE 'rectangle'
 165     type is (unrelated)
 166     !all are ok
 167     type is (square)
 168     type is (extsquare)
 169     !Handle same types
 170     type is (rectangle)
 171     !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 172     type is(integer)
 173     !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 174     type is(real)
 175     !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 176     type is(logical)
 177     !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 178     type is(character(len=*))
 179     !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement
 180     type is(complex)
 181   end select
 182
 183   !Unlimited polymorphic objects are allowed.
 184   unlim_polymorphic => rect_obj
 185   select type (unlim_polymorphic)
 186     type is (shape)
 187     type is (unrelated)
 188   end select
 189 end
 190
 191 module c1162a
 192   type pdt(kind,len)
 193     integer, kind :: kind
 194     integer, len :: len
 195   end type
 196  contains
 197   subroutine foo(x)
 198     class(pdt(kind=1,len=:)), allocatable :: x
 199     select type (x)
 200     type is (pdt(kind=1, len=*))
 201     !ERROR: Type specification 'pdt(kind=2_4,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
 202     type is (pdt(kind=2, len=*))
 203     !ERROR: Value of KIND type parameter 'kind' must be constant
 204     !ERROR: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
 205     type is (pdt(kind=*, len=*))
 206     end select
 207   end subroutine
 208 end module
 209
 210 subroutine CheckC1163
 211   use m1
 212   !assign dynamically
 213   shape_lim_polymorphic => rect_obj
 214   unlim_polymorphic => shape_obj
 215   select type (shape_lim_polymorphic)
 216     type is (shape)
 217     !ERROR: Type specification 'shape' conflicts with previous type specification
 218     type is (shape)
 219     class is (square)
 220     !ERROR: Type specification 'square' conflicts with previous type specification
 221     class is (square)
 222   end select
 223   select type (unlim_polymorphic)
 224     type is (INTEGER(4))
 225     type is (shape)
 226     !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
 227     type is (INTEGER(4))
 228   end select
 229 end
 230
 231 subroutine CheckC1164
 232   use m1
 233   shape_lim_polymorphic => rect_obj
 234   unlim_polymorphic => shape_obj
 235   select type (shape_lim_polymorphic)
 236     CLASS DEFAULT
 237     !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
 238     CLASS DEFAULT
 239     TYPE IS (shape)
 240     TYPE IS (rectangle)
 241     !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
 242     CLASS DEFAULT
 243   end select
 244
 245   !Saving computation if some error in guard by not computing RepeatingCases
 246   select type (shape_lim_polymorphic)
 247     CLASS DEFAULT
 248     CLASS DEFAULT
 249     !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
 250     TYPE IS(withSequence)
 251   end select
 252 end subroutine
 253
 254 subroutine WorkingPolymorphism
 255   use m1
 256   !assign dynamically
 257   shape_lim_polymorphic => rect_obj
 258   unlim_polymorphic => shape_obj
 259   select type (shape_lim_polymorphic)
 260     type is  (shape)
 261       print *, "hello shape"
 262     type is  (rectangle)
 263       print *, "hello rect"
 264     type is  (square)
 265       print *, "hello square"
 266     CLASS DEFAULT
 267       print *, "default"
 268   end select
 269   print *, "unlim polymorphism"
 270   select type (unlim_polymorphic)
 271     type is  (shape)
 272       print *, "hello shape"
 273     type is  (rectangle)
 274       print *, "hello rect"
 275     type is  (square)
 276       print *, "hello square"
 277     CLASS DEFAULT
 278       print *, "default"
 279   end select
 280 end
 281
 282 subroutine CheckNotProcedure
 283   use m1
 284   !ERROR: Selector may not be a procedure
 285   select type (x=>f)
 286   end select
 287  contains
 288   function f() result(res)
 289     class(shape), allocatable :: res
 290   end
 291
 292 subroutine CheckAssumedRankInSelectType(var)
 293   class(*), intent(in) :: var(..)
 294   !ERROR: Assumed-rank variable may only be used as actual argument
 295   select type(var)
 296   end select
 297  end
 298 end