flang/test/Semantics/selecttype01.f90

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