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: Type specification 'pdt(kind=*,len=*)' must be an extension of TYPE 'pdt(kind=1_4,len=:)'
 204     type is (pdt(kind=*, len=*))
 205     end select
 206   end subroutine
 207 end module
 208
 209 subroutine CheckC1163
 210   use m1
 211   !assign dynamically
 212   shape_lim_polymorphic => rect_obj
 213   unlim_polymorphic => shape_obj
 214   select type (shape_lim_polymorphic)
 215     type is (shape)
 216     !ERROR: Type specification 'shape' conflicts with previous type specification
 217     type is (shape)
 218     class is (square)
 219     !ERROR: Type specification 'square' conflicts with previous type specification
 220     class is (square)
 221   end select
 222   select type (unlim_polymorphic)
 223     type is (INTEGER(4))
 224     type is (shape)
 225     !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification
 226     type is (INTEGER(4))
 227   end select
 228 end
 229
 230 subroutine CheckC1164
 231   use m1
 232   shape_lim_polymorphic => rect_obj
 233   unlim_polymorphic => shape_obj
 234   select type (shape_lim_polymorphic)
 235     CLASS DEFAULT
 236     !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
 237     CLASS DEFAULT
 238     TYPE IS (shape)
 239     TYPE IS (rectangle)
 240     !ERROR: Type specification 'DEFAULT' conflicts with previous type specification
 241     CLASS DEFAULT
 242   end select
 243
 244   !Saving computation if some error in guard by not computing RepeatingCases
 245   select type (shape_lim_polymorphic)
 246     CLASS DEFAULT
 247     CLASS DEFAULT
 248     !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute
 249     TYPE IS(withSequence)
 250   end select
 251 end subroutine
 252
 253 subroutine WorkingPolymorphism
 254   use m1
 255   !assign dynamically
 256   shape_lim_polymorphic => rect_obj
 257   unlim_polymorphic => shape_obj
 258   select type (shape_lim_polymorphic)
 259     type is  (shape)
 260       print *, "hello shape"
 261     type is  (rectangle)
 262       print *, "hello rect"
 263     type is  (square)
 264       print *, "hello square"
 265     CLASS DEFAULT
 266       print *, "default"
 267   end select
 268   print *, "unlim polymorphism"
 269   select type (unlim_polymorphic)
 270     type is  (shape)
 271       print *, "hello shape"
 272     type is  (rectangle)
 273       print *, "hello rect"
 274     type is  (square)
 275       print *, "hello square"
 276     CLASS DEFAULT
 277       print *, "default"
 278   end select
 279 end