-
Notifications
You must be signed in to change notification settings - Fork 11.6k
/
selecttype01.f90
241 lines (221 loc) · 6.36 KB
/
selecttype01.f90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
! RUN: %S/test_errors.sh %s %t %f18
! 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
! 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)
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)
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)
end select
!Unlimited polymorphic objects are allowed.
unlim_polymorphic => rect_obj
select type (unlim_polymorphic)
type is (shape)
type is (unrelated)
end select
end
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
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