Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c36104a.ada @ 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
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 -- C36104A.ADA
2
3 -- Grant of Unlimited Rights
4 --
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
14 -- to do so.
15 --
16 -- DISCLAIMER
17 --
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
24 --*
25 -- CHECK THAT CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE,
26 -- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS,
27 -- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES,
28 -- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS,
29 -- WHERE AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE.
30 -- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT
31 -- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES.
32 -- ONLY STATIC CASES ARE CHECKED HERE.
33
34 -- DAT 2/3/81
35 -- JRK 2/25/81
36 -- VKG 1/21/83
37 -- L.BROWN 7/15/86 1) ADDED ACCESS TYPES.
38 -- 2) DELETED "NULL INDEX RANGES, CONSTRAINT_ERROR
39 -- RAISED" SECTION.
40 -- 3) DELETED ANY MENTION OF CASE STATEMENT CHOICES
41 -- AND VARIANT CHOICES IN THE ABOVE COMMENT.
42 -- EDS 7/16/98 AVOID OPTIMIZATION
43
44 WITH REPORT;
45 PROCEDURE C36104A IS
46
47 USE REPORT;
48
49 TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT);
50 TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK;
51 SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI;
52 SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU;
53
54 TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10;
55 TYPE I_10 IS NEW INT_10;
56 SUBTYPE I_5 IS I_10 RANGE -5 .. 5;
57 TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5;
58
59 BEGIN
60 TEST ("C36104A", "CONSTRAINT_ERROR IS RAISED OR NOT IN STATIC "
61 & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS");
62
63 -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED.
64
65 BEGIN
66 DECLARE
67 TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5;
68 -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
69 BEGIN
70 DECLARE
71 -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID
72 -- OPTIMIZATION OF SUBTYPE
73 A1 : A := (OTHERS => I_5(IDENT_INT(1)));
74 BEGIN
75 FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " &
76 I_5'IMAGE(A1(1)) ); --USE A1
77 END;
78 EXCEPTION
79 --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS
80 --REPORT FAILED.
81 WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1");
82 END;
83 EXCEPTION
84 WHEN CONSTRAINT_ERROR => NULL;
85 WHEN OTHERS =>
86 FAILED ("WRONG EXCEPTION RAISED 1");
87 END;
88
89 BEGIN
90 FOR I IN MID_WEEK RANGE MON .. MON LOOP
91 FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
92 END LOOP;
93 FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
94 EXCEPTION
95 WHEN CONSTRAINT_ERROR => NULL;
96 WHEN OTHERS =>
97 FAILED ("WRONG EXCEPTION RAISED 3");
98 END;
99
100 BEGIN
101 DECLARE
102 TYPE P IS ACCESS I_5_ARRAY (I_5 RANGE 0 .. 6);
103 -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
104 BEGIN
105 DECLARE
106 TYPE PA IS NEW P;
107 -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID
108 -- OPTIMIZATION OF TYPE
109 PA1 : PA := NEW I_5_ARRAY'(0 .. I_5(IDENT_INT(6)) =>
110 I_5(IDENT_INT(1)));
111 BEGIN
112 FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " &
113 I_5'IMAGE(PA1(1))); --USE PA1
114 END;
115 EXCEPTION
116 WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4");
117 END;
118 EXCEPTION
119 WHEN CONSTRAINT_ERROR => NULL;
120 WHEN OTHERS =>
121 FAILED ("WRONG EXCEPTION RAISED 4");
122 END;
123
124 DECLARE
125 W : WEEK_ARRAY (MID_WEEK);
126 BEGIN
127 W := (MID_WEEK RANGE MON .. WED => WED);
128 -- CONSTRAINT_ERROR RAISED.
129 FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " &
130 MID_WEEK'IMAGE(W(WED))); --USE W
131 EXCEPTION
132 WHEN CONSTRAINT_ERROR => NULL;
133 WHEN OTHERS =>
134 FAILED ("WRONG EXCEPTION RAISED 7");
135 END;
136
137 DECLARE
138 W : WEEK_ARRAY (WORK_WEEK);
139 BEGIN
140 W := (W'RANGE => WED); -- OK.
141 W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION.
142 FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
143 MID_WEEK'IMAGE(W(WED))); --USE W
144 EXCEPTION
145 WHEN CONSTRAINT_ERROR => NULL;
146 WHEN OTHERS =>
147 FAILED ("WRONG EXCEPTION RAISED 8");
148 END;
149
150 BEGIN
151 DECLARE
152 W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI);
153 -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR.
154 BEGIN
155 W := (W'RANGE => WED); -- OK.
156 FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " &
157 MID_WEEK'IMAGE(W(WED))); --USE W
158 EXCEPTION
159 WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 9");
160 END;
161 EXCEPTION
162 WHEN CONSTRAINT_ERROR => NULL;
163 WHEN OTHERS =>
164 FAILED ("WRONG EXCEPTION RAISED 9");
165 END;
166
167 BEGIN
168 DECLARE
169 TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. TUE);
170 -- RAISES CONSTRAINT_ERROR.
171 BEGIN
172 DECLARE
173 W1 : W := (OTHERS => WED);
174 BEGIN
175 FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " &
176 MID_WEEK'IMAGE(W1(WED))); --USE W1
177 END;
178 EXCEPTION
179 WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 10");
180 END;
181 EXCEPTION
182 WHEN CONSTRAINT_ERROR => NULL;
183 WHEN OTHERS =>
184 FAILED ("WRONG EXCEPTION RAISED 10");
185 END;
186
187 BEGIN
188 DECLARE
189 SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. WED);
190 -- RAISES CONSTRAINT_ERROR.
191 BEGIN
192 DECLARE
193 W1 : W := (OTHERS => (WED));
194 BEGIN
195 FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
196 MID_WEEK'IMAGE(W1(WED))); --USE W1
197 END;
198 EXCEPTION
199 WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8");
200 END;
201 EXCEPTION
202 WHEN CONSTRAINT_ERROR => NULL;
203 WHEN OTHERS =>
204 FAILED ("WRONG EXCEPTION RAISED 11");
205 END;
206
207 -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED.
208
209 BEGIN
210 DECLARE
211 TYPE A IS ARRAY (I_5 RANGE -5 .. -6) OF I_5;
212 A1 : A;
213 BEGIN
214 IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN
215 FAILED ("'FIRST OF NULL ARRAY INCORRECT");
216 END IF;
217 END;
218 EXCEPTION
219 WHEN OTHERS => FAILED ("EXCEPTION RAISED 1");
220 END;
221
222 BEGIN
223 FOR I IN MID_WEEK RANGE SAT .. SUN LOOP
224 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
225 END LOOP;
226 FOR I IN MID_WEEK RANGE FRI .. WED LOOP
227 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
228 END LOOP;
229 FOR I IN MID_WEEK RANGE MON .. SUN LOOP
230 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
231 END LOOP;
232 FOR I IN I_5 RANGE 10 .. -10 LOOP
233 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
234 END LOOP;
235 FOR I IN I_5 RANGE 10 .. 9 LOOP
236 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
237 END LOOP;
238 FOR I IN I_5 RANGE -10 .. -11 LOOP
239 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
240 END LOOP;
241 FOR I IN I_5 RANGE -10 .. -20 LOOP
242 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
243 END LOOP;
244 FOR I IN I_5 RANGE 6 .. 5 LOOP
245 FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES");
246 END LOOP;
247 EXCEPTION
248 WHEN OTHERS => FAILED ("EXCEPTION RAISED 3");
249 END;
250
251 BEGIN
252 DECLARE
253 TYPE P IS ACCESS I_5_ARRAY (-5 .. -6);
254 PA1 : P := NEW I_5_ARRAY (-5 .. -6);
255 BEGIN
256 IF PA1'LENGTH /= IDENT_INT(0) THEN
257 FAILED ("'LENGTH OF NULL ARRAY INCORRECT");
258 END IF;
259 END;
260 EXCEPTION
261 WHEN OTHERS =>
262 FAILED ("EXCEPTION RAISED 5");
263 END;
264
265 DECLARE
266 TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
267 SUBTYPE SNARR IS INTEGER RANGE 1 .. 2;
268 W : NARR(SNARR) := (1,2);
269 BEGIN
270 IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN
271 FAILED("EVALUATION OF EXPRESSION IS INCORRECT");
272 END IF;
273 EXCEPTION
274 WHEN OTHERS => FAILED ("EXCEPTION RAISED 7");
275 END;
276
277 DECLARE
278 W : WEEK_ARRAY (MID_WEEK);
279 BEGIN
280 W := (W'RANGE => WED); -- OK.
281 W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN);
282 EXCEPTION
283 WHEN OTHERS => FAILED ("EXCEPTION RAISED 8");
284 END;
285
286 BEGIN
287 DECLARE
288 W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN);
289 BEGIN
290 IF (W'FIRST /= MON) THEN
291 FAILED ("'FIRST OF NULL ARRAY INCORRECT");
292 END IF;
293 END;
294 EXCEPTION
295 WHEN OTHERS => FAILED ("EXCEPTION RAISED 9");
296 END;
297
298 BEGIN
299 DECLARE
300 TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
301 W1 : W;
302 BEGIN
303 IF (W1'FIRST /= TUE) THEN
304 FAILED ("'FIRST OF NULL ARRAY INCORRECT");
305 END IF;
306 END;
307 EXCEPTION
308 WHEN OTHERS => FAILED ("EXCEPTION RAISED 10");
309 END;
310
311 BEGIN
312 DECLARE
313 SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
314 W1 : W;
315 BEGIN
316 IF (W1'FIRST /= TUE) THEN
317 FAILED ("'FIRST OF NULL ARRAY INCORRECT");
318 END IF;
319 END;
320 EXCEPTION
321 WHEN OTHERS => FAILED ("EXCEPTION RAISED 12");
322 END;
323
324 -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED.
325
326 BEGIN
327 IF SUN IN SAT .. SUN
328 OR SAT IN FRI .. WED
329 OR WED IN THU .. TUE
330 OR THU IN MON .. SUN
331 OR FRI IN SAT .. FRI
332 OR WED IN FRI .. MON
333 THEN
334 FAILED ("INCORRECT 'IN' EVALUATION 1");
335 END IF;
336
337 IF INTEGER'(0) IN 10 .. -10
338 OR INTEGER'(0) IN 10 .. 9
339 OR INTEGER'(0) IN -10 .. -11
340 OR INTEGER'(0) IN -10 .. -20
341 OR INTEGER'(0) IN 6 .. 5
342 OR INTEGER'(0) IN 5 .. 3
343 OR INTEGER'(0) IN 7 .. 3
344 THEN
345 FAILED ("INCORRECT 'IN' EVALUATION 2");
346 END IF;
347
348 IF WED NOT IN THU .. TUE
349 AND INTEGER'(0) NOT IN 4 .. -4
350 THEN NULL;
351 ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION");
352 END IF;
353 EXCEPTION
354 WHEN OTHERS => FAILED ("EXCEPTION RAISED 52");
355 END;
356
357
358 RESULT;
359 END C36104A;