299 lines · plain
1! RUN: %python %S/test_errors.py %s %flang_fc12! Test for checking select type constraints,3module m14 use ISO_C_BINDING5 type shape6 integer :: color7 logical :: filled8 integer :: x9 integer :: y10 end type shape11 12 type, extends(shape) :: rectangle13 integer :: length14 integer :: width15 end type rectangle16 17 type, extends(rectangle) :: square18 end type square19 20 type, extends(square) :: extsquare21 end type22 23 type :: unrelated24 logical :: some_logical25 end type26 27 type withSequence28 SEQUENCE29 integer :: x30 end type31 32 type, BIND(C) :: withBind33 INTEGER(c_int) ::int_in_c34 end type35 36 TYPE(shape), TARGET :: shape_obj37 TYPE(rectangle), TARGET :: rect_obj38 TYPE(square), TARGET :: squr_obj39 !define polymorphic objects40 class(*), pointer :: unlim_polymorphic41 class(shape), pointer :: shape_lim_polymorphic42end43module m44 type :: t(n)45 integer, len :: n46 end type47contains48 subroutine CheckC1160( a )49 class(*), intent(in) :: a50 select type ( a )51 !ERROR: The type specification statement must have LEN type parameter as assumed52 type is ( character(len=10) ) !<-- assumed length-type53 !ERROR: The type specification statement must have LEN type parameter as assumed54 type is ( character )55 ! OK56 type is ( character(len=*) )57 !ERROR: The type specification statement must have LEN type parameter as assumed58 type is ( t(n=10) )59 ! OK60 type is ( t(n=*) ) !<-- assumed length-type61 !ERROR: Derived type 'character' not found62 class is ( character(len=10) ) !<-- assumed length-type63 end select64 end subroutine65 66 subroutine s()67 type derived(param)68 integer, len :: param69 class(*), allocatable :: x70 end type71 TYPE(derived(10)) :: a72 select type (ax => a%x)73 class is (derived(param=*))74 print *, "hello"75 end select76 end subroutine s77end module78 79subroutine CheckC115780 use m181 integer, parameter :: const_var=1082 !ERROR: Selector is not a named variable: 'associate-name =>' is required83 select type(10)84 end select85 !ERROR: Selector is not a named variable: 'associate-name =>' is required86 select type(const_var)87 end select88 !ERROR: Selector is not a named variable: 'associate-name =>' is required89 select type (4.999)90 end select91 !ERROR: Selector is not a named variable: 'associate-name =>' is required92 select type (shape_obj%x)93 end select94end subroutine95 96!CheckPloymorphicSelectorType97subroutine CheckC1159a98 integer :: int_variable99 real :: real_variable100 complex :: complex_var = cmplx(3.0, 4.0)101 logical :: log_variable102 character (len=10) :: char_variable = "OM"103 !ERROR: Selector 'int_variable' in SELECT TYPE statement must be polymorphic104 select type (int_variable)105 end select106 !ERROR: Selector 'real_variable' in SELECT TYPE statement must be polymorphic107 select type (real_variable)108 end select109 !ERROR: Selector 'complex_var' in SELECT TYPE statement must be polymorphic110 select type(complex_var)111 end select112 !ERROR: Selector 'logical_variable' in SELECT TYPE statement must be polymorphic113 select type(logical_variable)114 end select115 !ERROR: Selector 'char_variable' in SELECT TYPE statement must be polymorphic116 select type(char_variable)117 end select118end119 120subroutine CheckC1159b121 integer :: x122 !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic123 select type (a => x)124 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement125 type is (integer)126 print *,'integer ',a127 end select128end129 130subroutine CheckC1159c131 !ERROR: Selector 'x' in SELECT TYPE statement must be polymorphic132 select type (a => x)133 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement134 type is (integer)135 print *,'integer ',a136 end select137end138 139subroutine s(arg)140 class(*) :: arg141 select type (arg)142 type is (integer)143 end select144end145 146subroutine CheckC1161147 use m1148 shape_lim_polymorphic => rect_obj149 select type(shape_lim_polymorphic)150 !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute151 type is (withSequence)152 !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute153 type is (withBind)154 end select155end156 157subroutine CheckC1162158 use m1159 class(rectangle), pointer :: rectangle_polymorphic160 !not unlimited polymorphic objects161 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 ok167 type is (square)168 type is (extsquare)169 !Handle same types170 type is (rectangle)171 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement172 type is(integer)173 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement174 type is(real)175 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement176 type is(logical)177 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement178 type is(character(len=*))179 !ERROR: If selector is not unlimited polymorphic, an intrinsic type specification must not be specified in the type guard statement180 type is(complex)181 end select182 183 !Unlimited polymorphic objects are allowed.184 unlim_polymorphic => rect_obj185 select type (unlim_polymorphic)186 type is (shape)187 type is (unrelated)188 end select189end190 191module c1162a192 type pdt(kind,len)193 integer, kind :: kind194 integer, len :: len195 end type196 contains197 subroutine foo(x)198 class(pdt(kind=1,len=:)), allocatable :: x199 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 constant204 !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 select207 end subroutine208end module209 210subroutine CheckC1163211 use m1212 !assign dynamically213 shape_lim_polymorphic => rect_obj214 unlim_polymorphic => shape_obj215 select type (shape_lim_polymorphic)216 type is (shape)217 !ERROR: Type specification 'shape' conflicts with previous type specification218 type is (shape)219 class is (square)220 !ERROR: Type specification 'square' conflicts with previous type specification221 class is (square)222 end select223 select type (unlim_polymorphic)224 type is (INTEGER(4))225 type is (shape)226 !ERROR: Type specification 'INTEGER(4)' conflicts with previous type specification227 type is (INTEGER(4))228 end select229end230 231subroutine CheckC1164232 use m1233 shape_lim_polymorphic => rect_obj234 unlim_polymorphic => shape_obj235 select type (shape_lim_polymorphic)236 CLASS DEFAULT237 !ERROR: Type specification 'DEFAULT' conflicts with previous type specification238 CLASS DEFAULT239 TYPE IS (shape)240 TYPE IS (rectangle)241 !ERROR: Type specification 'DEFAULT' conflicts with previous type specification242 CLASS DEFAULT243 end select244 245 !Saving computation if some error in guard by not computing RepeatingCases246 select type (shape_lim_polymorphic)247 CLASS DEFAULT248 CLASS DEFAULT249 !ERROR: The type specification statement must not specify a type with a SEQUENCE attribute or a BIND attribute250 TYPE IS(withSequence)251 end select252end subroutine253 254subroutine WorkingPolymorphism255 use m1256 !assign dynamically257 shape_lim_polymorphic => rect_obj258 unlim_polymorphic => shape_obj259 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 DEFAULT267 print *, "default"268 end select269 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 DEFAULT278 print *, "default"279 end select280end281 282subroutine CheckNotProcedure283 use m1284 !ERROR: Selector may not be a procedure285 select type (x=>f)286 end select287 contains288 function f() result(res)289 class(shape), allocatable :: res290 end291 292subroutine CheckAssumedRankInSelectType(var)293 class(*), intent(in) :: var(..)294 !ERROR: Assumed-rank variable may only be used as actual argument295 select type(var)296 end select297 end298end299