3 ! Basic tests of functionality of unlimited polymorphism
\r
5 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
\r
13 subroutine bar (arg, res)
\r
15 character(100) :: res
\r
16 select type (w => arg)
\r
18 write (res, '(a, I4)') "type(a)", w%i
\r
20 write (res, '(a, I4)') "integer", w
\r
22 write (res, '(a, F4.1)') "real4", w
\r
24 write (res, '(a, F4.1)') "real8", w
\r
25 type is (character(*, kind = 4))
\r
27 type is (character(*))
\r
28 write (res, '(a, I2, a, a)') "char(", LEN(w), ")", trim(w)
\r
32 subroutine foo (arg, res)
\r
34 character(100) :: res
\r
35 select type (w => arg)
\r
37 write (res,'(a, 10I4)') "type(a) array", w%i
\r
39 write (res,'(a, 10I4)') "integer array", w
\r
41 write (res,'(a, 10F4.1)') "real array", w
\r
42 type is (character(*))
\r
43 write (res, '(a5, I2, a, I2, a1, 2(a))') &
\r
44 "char(",len(w),",", size(w,1),") array ", w
\r
51 TYPE(a), target :: obj1 = a(99)
\r
52 TYPE(a), target :: obj2(3) = a(999)
\r
53 integer, target :: obj3 = 999
\r
54 real(4), target :: obj4(4) = [(real(i), i = 1, 4)]
\r
55 integer, target :: obj5(3) = [(i*99, i = 1, 3)]
\r
56 class(*), pointer :: u1
\r
57 class(*), pointer :: u2(:)
\r
58 class(*), allocatable :: u3
\r
59 class(*), allocatable :: u4(:)
\r
60 type(a), pointer :: aptr(:)
\r
61 character(8) :: sun = "sunshine"
\r
62 character(100) :: res
\r
64 ! NULL without MOLD used to cause segfault
\r
68 ! Test pointing to derived types.
\r
70 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
\r
73 if (trim (res) .ne. "type(a) 99") call abort
\r
76 if (trim (res) .ne. "type(a) array 999 999 999") call abort
\r
78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) call abort
\r
80 ! Check allocate with an array SOURCE.
\r
81 allocate (u2(5), source = [(a(i), i = 1,5)])
\r
82 if (SAME_TYPE_AS (u1, a(2)) .neqv. .TRUE.) call abort
\r
84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") call abort
\r
88 ! Point to intrinsic targets.
\r
91 if (trim (res) .ne. "integer 999") call abort
\r
95 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
\r
99 if (trim (res) .ne. "integer array 99 198 297") call abort
\r
101 ! Test allocate with source.
\r
102 allocate (u1, source = sun)
\r
104 if (trim (res) .ne. "char( 8)sunshine") call abort
\r
107 allocate (u2(3), source = [7,8,9])
\r
109 if (trim (res) .ne. "integer array 7 8 9") call abort
\r
113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) call abort
\r
114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
\r
116 allocate (u2(3), source = [5.0,6.0,7.0])
\r
118 if (trim (res) .ne. "real array 5.0 6.0 7.0") call abort
\r
120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) call abort
\r
121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) call abort
\r
124 ! Check allocate with a MOLD tag.
\r
125 allocate (u2(3), mold = 8.0)
\r
127 if (res(1:10) .ne. "real array") call abort
\r
130 ! Test passing an intrinsic type to a CLASS(*) formal.
\r
132 if (trim (res) .ne. "integer 1") call abort
\r
135 if (trim (res) .ne. "real4 2.0") call abort
\r
138 if (trim (res) .ne. "real8 2.0") call abort
\r
140 call bar(a(3), res)
\r
141 if (trim (res) .ne. "type(a) 3") call abort
\r
144 if (trim (res) .ne. "char( 8)sunshine") call abort
\r
146 call bar (obj3, res)
\r
147 if (trim (res) .ne. "integer 999") call abort
\r
149 call foo([4,5], res)
\r
150 if (trim (res) .ne. "integer array 4 5") call abort
\r
152 call foo([6.0,7.0], res)
\r
153 if (trim (res) .ne. "real array 6.0 7.0") call abort
\r
155 call foo([a(8),a(9)], res)
\r
156 if (trim (res) .ne. "type(a) array 8 9") call abort
\r
158 call foo([sun, " & rain"], res)
\r
159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") call abort
\r
161 call foo([sun//" never happens", " & rain always happens"], res)
\r
162 if (trim (res) .ne. "char(22, 2)sunshine never happens & rain always happens") call abort
\r
164 call foo (obj4, res)
\r
165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") call abort
\r
167 call foo (obj5, res)
\r
168 if (trim (res) .ne. "integer array 99 198 297") call abort
\r
170 ! Allocatable entities
\r
171 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
\r
172 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
\r
173 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
\r
174 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
\r
176 allocate (u3, source = 2.4)
\r
178 if (trim (res) .ne. "real4 2.4") call abort
\r
180 allocate (u4(2), source = [a(88), a(99)])
\r
182 if (trim (res) .ne. "type(a) array 88 99") call abort
\r
184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) call abort
\r
185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
\r
188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) call abort
\r
189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) call abort
\r
191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
\r
192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) call abort
\r
194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) call abort
\r
195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) call abort
\r
198 ! Check assumed rank calls
\r
199 call foobar (u3, 0)
\r
200 call foobar (u4, 1)
\r
203 subroutine foobar (arg, ranki)
\r
204 class(*) :: arg (..)
\r
208 if (i .ne. ranki) call abort
\r