Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/gfortran.dg/unlimited_polymorphic_1.f03 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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