|
111
|
1 ! { dg-do run }
|
|
|
2 !
|
|
|
3 ! Basic tests of functionality of unlimited polymorphism
|
|
|
4 !
|
|
|
5 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
|
|
|
6 !
|
|
|
7 MODULE m
|
|
|
8 TYPE :: a
|
|
|
9 integer :: i
|
|
|
10 END TYPE
|
|
|
11
|
|
|
12 contains
|
|
|
13 subroutine bar (arg, res)
|
|
|
14 class(*) :: arg
|
|
|
15 character(100) :: res
|
|
|
16 select type (w => arg)
|
|
|
17 type is (a)
|
|
|
18 write (res, '(a, I4)') "type(a)", w%i
|
|
|
19 type is (integer)
|
|
|
20 write (res, '(a, I4)') "integer", w
|
|
|
21 type is (real(4))
|
|
|
22 write (res, '(a, F4.1)') "real4", w
|
|
|
23 type is (real(8))
|
|
|
24 write (res, '(a, F4.1)') "real8", w
|
|
|
25 type is (character(*, kind = 4))
|
|
|
26 call abort
|
|
|
27 type is (character(*))
|
|
|
28 write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w)
|
|
|
29 end select
|
|
|
30 end subroutine
|
|
|
31
|
|
|
32 subroutine foo (arg, res)
|
|
|
33 class(*) :: arg (:)
|
|
|
34 character(100) :: res
|
|
|
35 select type (w => arg)
|
|
|
36 type is (a)
|
|
|
37 write (res,'(a, 10I4)') "type(a) array", w%i
|
|
|
38 type is (integer)
|
|
|
39 write (res,'(a, 10I4)') "integer array", w
|
|
|
40 type is (real)
|
|
|
41 write (res,'(a, 10F4.1)') "real array", w
|
|
|
42 type is (character(*))
|
|
|
43 write (res, '(a5, I2, a, I2, a1, 2(a))') &
|
|
|
44 "char(",len(w),",", size(w,1),") array ", w
|
|
|
45 end select
|
|
|
46 end subroutine
|
|
|
47 END MODULE
|
|
|
48
|
|
|
49
|
|
|
50 USE m
|
|
|
51 TYPE(a), target :: obj1 = a(99)
|
|
|
52 TYPE(a), target :: obj2(3) = a(999)
|
|
|
53 integer, target :: obj3 = 999
|
|
|
54 real(4), target :: obj4(4) = [(real(i), i = 1, 4)]
|
|
|
55 integer, target :: obj5(3) = [(i*99, i = 1, 3)]
|
|
|
56 class(*), pointer :: u1
|
|
|
57 class(*), pointer :: u2(:)
|
|
|
58 class(*), allocatable :: u3
|
|
|
59 class(*), allocatable :: u4(:)
|
|
|
60 type(a), pointer :: aptr(:)
|
|
|
61 character(8) :: sun = "sunshine"
|
|
|
62 character(100) :: res
|
|
|
63
|
|
|
64 ! NULL without MOLD used to cause segfault
|
|
|
65 u2 => NULL()
|
|
|
66 u2 => NULL(aptr)
|
|
|
67
|
|
|
68 ! Test pointing to derived types.
|
|
|
69 u1 => obj1
|
|
|
70 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
|
|
|
71 u2 => obj2
|
|
|
72 call bar (u1, res)
|
|
|
73 if (trim (res) .ne. "type(a) 99") call abort
|
|
|
74
|
|
|
75 call foo (u2, res)
|
|
|
76 if (trim (res) .ne. "type(a) array 999 999 999") call abort
|
|
|
77
|
|
|
78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
|
|
|
79
|
|
|
80 ! Check allocate with an array SOURCE.
|
|
|
81 allocate (u2(5), source = [(a(i), i = 1,5)])
|
|
|
82 if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort
|
|
|
83 call foo (u2, res)
|
|
|
84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort
|
|
|
85
|
|
|
86 deallocate (u2)
|
|
|
87
|
|
|
88 ! Point to intrinsic targets.
|
|
|
89 u1 => obj3
|
|
|
90 call bar (u1, res)
|
|
|
91 if (trim (res) .ne. "integer 999") call abort
|
|
|
92
|
|
|
93 u2 => obj4
|
|
|
94 call foo (u2, res)
|
|
|
95 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
|
|
|
96
|
|
|
97 u2 => obj5
|
|
|
98 call foo (u2, res)
|
|
|
99 if (trim (res) .ne. "integer array 99 198 297") call abort
|
|
|
100
|
|
|
101 ! Test allocate with source.
|
|
|
102 allocate (u1, source = sun)
|
|
|
103 call bar (u1, res)
|
|
|
104 if (trim (res) .ne. "char( 8)sunshine") call abort
|
|
|
105 deallocate (u1)
|
|
|
106
|
|
|
107 allocate (u2(3), source = [7,8,9])
|
|
|
108 call foo (u2, res)
|
|
|
109 if (trim (res) .ne. "integer array 7 8 9") call abort
|
|
|
110
|
|
|
111 deallocate (u2)
|
|
|
112
|
|
|
113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort
|
|
|
114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
|
|
|
115
|
|
|
116 allocate (u2(3), source = [5.0,6.0,7.0])
|
|
|
117 call foo (u2, res)
|
|
|
118 if (trim (res) .ne. "real array 5.0 6.0 7.0") call abort
|
|
|
119
|
|
|
120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort
|
|
|
121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
|
|
|
122 deallocate (u2)
|
|
|
123
|
|
|
124 ! Check allocate with a MOLD tag.
|
|
|
125 allocate (u2(3), mold = 8.0)
|
|
|
126 call foo (u2, res)
|
|
|
127 if (res(1:10) .ne. "real array") call abort
|
|
|
128 deallocate (u2)
|
|
|
129
|
|
|
130 ! Test passing an intrinsic type to a CLASS(*) formal.
|
|
|
131 call bar(1, res)
|
|
|
132 if (trim (res) .ne. "integer 1") call abort
|
|
|
133
|
|
|
134 call bar(2.0, res)
|
|
|
135 if (trim (res) .ne. "real4 2.0") call abort
|
|
|
136
|
|
|
137 call bar(2d0, res)
|
|
|
138 if (trim (res) .ne. "real8 2.0") call abort
|
|
|
139
|
|
|
140 call bar(a(3), res)
|
|
|
141 if (trim (res) .ne. "type(a) 3") call abort
|
|
|
142
|
|
|
143 call bar(sun, res)
|
|
|
144 if (trim (res) .ne. "char( 8)sunshine") call abort
|
|
|
145
|
|
|
146 call bar (obj3, res)
|
|
|
147 if (trim (res) .ne. "integer 999") call abort
|
|
|
148
|
|
|
149 call foo([4,5], res)
|
|
|
150 if (trim (res) .ne. "integer array 4 5") call abort
|
|
|
151
|
|
|
152 call foo([6.0,7.0], res)
|
|
|
153 if (trim (res) .ne. "real array 6.0 7.0") call abort
|
|
|
154
|
|
|
155 call foo([a(8),a(9)], res)
|
|
|
156 if (trim (res) .ne. "type(a) array 8 9") call abort
|
|
|
157
|
|
|
158 call foo([sun, " & rain"], res)
|
|
|
159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort
|
|
|
160
|
|
|
161 call foo([sun//" never happens", " & rain always happens"], res)
|
|
|
162 if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort
|
|
|
163
|
|
|
164 call foo (obj4, res)
|
|
|
165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
|
|
|
166
|
|
|
167 call foo (obj5, res)
|
|
|
168 if (trim (res) .ne. "integer array 99 198 297") call abort
|
|
|
169
|
|
|
170 ! Allocatable entities
|
|
|
171 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
|
|
|
172 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
|
|
|
173 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
|
|
|
174 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
|
|
|
175
|
|
|
176 allocate (u3, source = 2.4)
|
|
|
177 call bar (u3, res)
|
|
|
178 if (trim (res) .ne. "real4 2.4") call abort
|
|
|
179
|
|
|
180 allocate (u4(2), source = [a(88), a(99)])
|
|
|
181 call foo (u4, res)
|
|
|
182 if (trim (res) .ne. "type(a) array 88 99") call abort
|
|
|
183
|
|
|
184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort
|
|
|
185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
|
|
|
186
|
|
|
187 deallocate (u3)
|
|
|
188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
|
|
|
189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
|
|
|
190
|
|
|
191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
|
|
|
192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort
|
|
|
193 deallocate (u4)
|
|
|
194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
|
|
|
195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
|
|
|
196
|
|
|
197
|
|
|
198 ! Check assumed rank calls
|
|
|
199 call foobar (u3, 0)
|
|
|
200 call foobar (u4, 1)
|
|
|
201 contains
|
|
|
202
|
|
|
203 subroutine foobar (arg, ranki)
|
|
|
204 class(*) :: arg (..)
|
|
|
205 integer :: ranki
|
|
|
206 integer i
|
|
|
207 i = rank (arg)
|
|
|
208 if (i .ne. ranki) call abort
|
|
|
209 end subroutine
|
|
|
210
|
|
|
211 END
|
