| blob | afd752242bbdf614bb6b57335d7f399b9e554491 |
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 STOP 1
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.) STOP 1
71 u2 => obj2\r
72 call bar (u1, res)\r
73 if (trim (res) .ne. "type(a) 99") STOP 1
74 \r
75 call foo (u2, res)\r
76 if (trim (res) .ne. "type(a) array 999 999 999") STOP 1
77 \r
78 if (SAME_TYPE_AS (obj1, u1) .neqv. .TRUE.) STOP 1
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.) STOP 1
83 call foo (u2, res)\r
84 if (trim (res) .ne. "type(a) array 1 2 3 4 5") STOP 1
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") STOP 1
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") STOP 1
96 \r
97 u2 => obj5\r
98 call foo (u2, res)\r
99 if (trim (res) .ne. "integer array 99 198 297") STOP 1
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") STOP 1
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") STOP 1
110 \r
111 deallocate (u2)\r
112 \r
113 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .TRUE.) STOP 1
114 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1
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") STOP 1
119 \r
120 if (EXTENDS_TYPE_OF (obj1, u2) .neqv. .FALSE.) STOP 1
121 if (EXTENDS_TYPE_OF (u2, obj1) .neqv. .FALSE.) STOP 1
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") STOP 1
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") STOP 1
133 \r
134 call bar(2.0, res)\r
135 if (trim (res) .ne. "real4 2.0") STOP 1
136 \r
137 call bar(2d0, res)\r
138 if (trim (res) .ne. "real8 2.0") STOP 1
139 \r
140 call bar(a(3), res)\r
141 if (trim (res) .ne. "type(a) 3") STOP 1
142 \r
143 call bar(sun, res)\r
144 if (trim (res) .ne. "char( 8)sunshine") STOP 1
145 \r
146 call bar (obj3, res)\r
147 if (trim (res) .ne. "integer 999") STOP 1
148 \r
149 call foo([4,5], res)\r
150 if (trim (res) .ne. "integer array 4 5") STOP 1
151 \r
152 call foo([6.0,7.0], res)\r
153 if (trim (res) .ne. "real array 6.0 7.0") STOP 1
154 \r
155 call foo([a(8),a(9)], res)\r
156 if (trim (res) .ne. "type(a) array 8 9") STOP 1
157 \r
158 call foo([sun, " & rain"], res)\r
159 if (trim (res) .ne. "char( 8, 2)sunshine & rain") STOP 1
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") STOP 1
163 \r
164 call foo (obj4, res)\r
165 if (trim (res) .ne. "real array 1.0 2.0 3.0 4.0") STOP 1
166 \r
167 call foo (obj5, res)\r
168 if (trim (res) .ne. "integer array 99 198 297") STOP 1
169 \r
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
175 \r
176 allocate (u3, source = 2.4)\r
177 call bar (u3, res)\r
178 if (trim (res) .ne. "real4 2.4") STOP 1
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") STOP 1
183 \r
184 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .FALSE.) STOP 1
185 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1
186 \r
187 deallocate (u3)\r
188 if (EXTENDS_TYPE_OF (obj1, u3) .neqv. .TRUE.) STOP 1
189 if (EXTENDS_TYPE_OF (u3, obj1) .neqv. .FALSE.) STOP 1
190 \r
191 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1
192 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .TRUE.) STOP 1
193 deallocate (u4)\r
194 if (EXTENDS_TYPE_OF (obj1, u4) .neqv. .TRUE.) STOP 1
195 if (EXTENDS_TYPE_OF (u4, obj1) .neqv. .FALSE.) STOP 1
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) STOP 1
209 end subroutine\r
210 \r
211 END\r