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.) STOP 1
73 if (trim (res) .ne. "type(a) 99") STOP 1
76 if (trim (res) .ne. "type(a) array 999 999 999") STOP 1
78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1
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.) STOP 1
84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") STOP 1
88 ! Point to intrinsic targets.
\r
91 if (trim (res) .ne. "integer 999") STOP 1
95 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1
99 if (trim (res) .ne. "integer array 99 198 297") STOP 1
101 ! Test allocate with source.
\r
102 allocate (u1, source = sun)
\r
104 if (trim (res) .ne. "char( 8)sunshine") STOP 1
107 allocate (u2(3), source = [7,8,9])
\r
109 if (trim (res) .ne. "integer array 7 8 9") STOP 1
113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) STOP 1
114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1
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") STOP 1
120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) STOP 1
121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1
124 ! Check allocate with a MOLD tag.
\r
125 allocate (u2(3), mold = 8.0)
\r
127 if (res(1:10) .ne. "real array") STOP 1
130 ! Test passing an intrinsic type to a CLASS(*) formal.
\r
132 if (trim (res) .ne. "integer 1") STOP 1
135 if (trim (res) .ne. "real4 2.0") STOP 1
138 if (trim (res) .ne. "real8 2.0") STOP 1
140 call bar(a(3), res)
\r
141 if (trim (res) .ne. "type(a) 3") STOP 1
144 if (trim (res) .ne. "char( 8)sunshine") STOP 1
146 call bar (obj3, res)
\r
147 if (trim (res) .ne. "integer 999") STOP 1
149 call foo([4,5], res)
\r
150 if (trim (res) .ne. "integer array 4 5") STOP 1
152 call foo([6.0,7.0], res)
\r
153 if (trim (res) .ne. "real array 6.0 7.0") STOP 1
155 call foo([a(8),a(9)], res)
\r
156 if (trim (res) .ne. "type(a) array 8 9") STOP 1
158 call foo([sun, " & rain"], res)
\r
159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") STOP 1
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") STOP 1
164 call foo (obj4, res)
\r
165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1
167 call foo (obj5, res)
\r
168 if (trim (res) .ne. "integer array 99 198 297") STOP 1
170 ! Allocatable entities
\r
171 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1
172 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1
173 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1
174 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1
176 allocate (u3, source = 2.4)
\r
178 if (trim (res) .ne. "real4 2.4") STOP 1
180 allocate (u4(2), source = [a(88), a(99)])
\r
182 if (trim (res) .ne. "type(a) array 88 99") STOP 1
184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) STOP 1
185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1
188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1
189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1
191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1
192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) STOP 1
194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1
195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1
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) STOP 1