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