Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c432003.a @ 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 -- C432003.A
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 --
26 -- OBJECTIVE:
27 -- Check that if the type of the ancestor part of an extension aggregate
28 -- has discriminants that are not inherited by the type of the aggregate,
29 -- and the ancestor part is a subtype mark that denotes a constrained
30 -- subtype, Constraint_Error is raised if: 1) any discriminant of the
31 -- ancestor has a different value than that specified for a corresponding
32 -- discriminant in the derived type definition for some ancestor of the
33 -- type of the aggregate, or 2) the value for the discriminant in the
34 -- record association list is not the value of the corresponding
35 -- discriminant. Check that the components of the value of the
36 -- aggregate not given by the record component association list are
37 -- initialized by default as for an object of the ancestor type.
38 --
39 -- TEST DESCRIPTION:
40 -- Consider:
41 --
42 -- type T (D1: ...) is tagged ...
43 --
44 -- type DT is new T with ...
45 -- subtype ST is DT (D1 => 3); -- Constrained subtype.
46 --
47 -- type NT1 (D2: ...) is new DT (D1 => D2) with null record;
48 -- type NT2 (D2: ...) is new DT (D1 => 6) with null record;
49 -- type NT3 is new DT (D1 => 6) with null record;
50 --
51 -- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained.
52 -- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained.
53 -- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2.
54 --
55 -- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained.
56 -- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained.
57 -- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2.
58 --
59 -- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained.
60 -- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained.
61 -- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3.
62 --
63 -- In A, B, D, E, G, and H the ancestor part is the name of an
64 -- unconstrained subtype, so this rule does not apply. In C, F, and I
65 -- the ancestor part (ST) is the name of a constrained subtype of DT,
66 -- which is itself a derived type of a discriminated tagged type T. ST
67 -- constrains the discriminant of DT (D1) to the value 3; thus, the
68 -- type of any extension aggregate for which ST is the ancestor part
69 -- must have an ancestor which also constrained D1 to 3. F and I raise
70 -- Constraint_Error because NT2 and NT3, respectively, constrain D1 to
71 -- 6. C raises Constraint_Error because NT1 constrains D1 to the value
72 -- of D2, which is set to 6 in the record component association list of
73 -- the aggregate.
74 --
75 -- This test verifies each of the three scenarios above:
76 --
77 -- (1) Ancestor of type of aggregate constrains discriminant with
78 -- new discriminant.
79 -- (2) Ancestor of type of aggregate constrains discriminant with
80 -- value, and has a new discriminant part.
81 -- (3) Ancestor of type of aggregate constrains discriminant with
82 -- value, and has no discriminant part.
83 --
84 -- Verification is made for cases where the type of the aggregate is
85 -- once- and twice-removed from the type of the ancestor part.
86 --
87 -- Additionally, a case is included where a new discriminant corresponds
88 -- to multiple discriminants of the type of the ancestor part.
89 --
90 -- To test the portion of the objective concerning "initialization by
91 -- default," the test verifies that, after a successful aggregate
92 -- assignment, components not assigned an explicit value by the aggregate
93 -- contain the default values for the corresponding components of the
94 -- ancestor type.
95 --
96 --
97 -- CHANGE HISTORY:
98 -- 06 Dec 94 SAIC ACVC 2.0
99 -- 15 Dec 94 SAIC Removed discriminant defaults from tagged types.
100 -- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint
101 -- for component NT_C3.Str2. Added missing component
102 -- checks. Removed record component update from
103 -- Avoid_Optimization. Fixed incorrect component
104 -- checks.
105 -- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for
106 -- Q case.
107 --
108 --!
109
110 package C432003_0 is
111
112 Default_String : constant String := "This is a default string"; -- len = 24
113 Another_String : constant String := "Another default string"; -- len = 22
114
115 subtype Length is Natural range 0..255;
116
117 type ROOT (D1 : Length) is tagged
118 record
119 S1 : String (1..D1) := Default_String(1..D1);
120 Acc : Natural := 356;
121 end record;
122
123 procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type
124 -- extensions.
125
126 type Unconstrained_Der is new ROOT with
127 record
128 Str1 : String(1..5) := "abcde";
129 end record;
130
131 subtype Constrained_Subtype is Unconstrained_Der (D1 => 10);
132
133 type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with
134 record
135 S2 : String(1..D2); -- Inherited discrim. constrained by
136 end record; -- new discriminant.
137
138 type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with
139 record
140 S3 : String(1..D3); -- Inherited discrim. constrained by
141 end record; -- new discriminant.
142
143
144 type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with
145 record
146 S2 : String(1..D2); -- Inherited discrim. constrained by
147 end record; -- explicit value.
148
149 type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with
150 record
151 S3 : String(1..D3); -- Inherited discrim. constrained by
152 end record; -- explicit value.
153
154 type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with
155 record
156 S2 : String(1..D2);
157 end record;
158
159
160 type NT_C1 is new Unconstrained_Der (D1 => 5) with
161 record
162 Str2 : String(1..5); -- Inherited discrim. constrained
163 end record; -- No new value.
164
165 type NT_C2 (D2 : Length) is new NT_C1 with
166 record
167 S2 : String(1..D2); -- Inherited discrim. not further
168 end record; -- constrained, new discriminant.
169
170 type NT_C3 is new Unconstrained_Der(D1 => 10) with
171 record
172 Str2 : String(1..5);
173 end record;
174
175
176 type MULTI_ROOT (D1 : Length; D2 : Length) is tagged
177 record
178 S1 : String (1..D1) := Default_String(1..D1);
179 S2 : String (1..D2) := Another_String(1..D2);
180 end record;
181
182 procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all
183 -- type extensions.
184
185 type Mult_Unconstr_Der is new MULTI_ROOT with
186 record
187 Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints.
188 end record;
189
190 -- Subtypes with constrained discriminants.
191 subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
192 D2 => 20); -- diff values
193
194 subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have
195 D2 => 15); -- same value
196
197 type Mult_NT_A1 (D3 : Length) is
198 new Mult_Unconstr_Der (D1 => D3, D2 => D3) with
199 record
200 S3 : String(1..D3); -- Both inherited discriminants constrained
201 end record; -- by new discriminant.
202
203 end C432003_0;
204
205
206 --=====================================================================--
207
208
209 with Report;
210 package body C432003_0 is
211
212 procedure Avoid_Optimization (Rec : in out ROOT) is
213 begin
214 Rec.S1 := Report.Ident_Str(Rec.S1);
215 end Avoid_Optimization;
216
217 procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is
218 begin
219 Rec.S1 := Report.Ident_Str(Rec.S1);
220 end Avoid_Optimization;
221
222 end C432003_0;
223
224
225 --=====================================================================--
226
227
228 with C432003_0;
229 with Report;
230 procedure C432003 is
231 begin
232
233 Report.Test("C432003", "Extension aggregates where ancestor part " &
234 "is a subtype mark that denotes a constrained " &
235 "subtype causing Constraint_Error if any " &
236 "discriminant of the ancestor has a different " &
237 "value than that specified for a corresponding " &
238 "discriminant in the derived type definition " &
239 "for some ancestor of the type of the aggregate");
240
241 Test_Block:
242 declare
243
244 -- Variety of string object declarations.
245 String2 : String(1..2) := Report.Ident_Str("12");
246 String5 : String(1..5) := Report.Ident_Str("12345");
247 String8 : String(1..8) := Report.Ident_Str("AbCdEfGh");
248 String10 : String(1..10) := Report.Ident_Str("1234567890");
249 String15 : String(1..15) := Report.Ident_Str("123456789012345");
250 String20 : String(1..20) := Report.Ident_Str("12345678901234567890");
251
252 begin
253
254
255 begin
256 declare
257 A : C432003_0.NT_A1 := -- OK
258 (C432003_0.ROOT with D2 => 5,
259 Str1 => "cdefg",
260 S2 => String5);
261 begin
262 C432003_0.Avoid_Optimization(A);
263 if A.Acc /= 356 or
264 A.Str1 /= "cdefg" or
265 A.S2 /= String5 or
266 A.D2 /= 5 or
267 A.S1 /= C432003_0.Default_String(1..5)
268 then
269 Report.Failed("Incorrect object values for Object A");
270 end if;
271 end;
272 exception
273 when Constraint_Error =>
274 Report.Failed("Constraint_Error raised for Object A");
275 end;
276
277
278 begin
279 declare
280 C: C432003_0.NT_A1 := -- OK
281 (C432003_0.Constrained_Subtype with D2 => 10,
282 S2 => String10);
283 begin
284 C432003_0.Avoid_Optimization(C);
285 if C.D2 /= 10 or C.Acc /= 356 or
286 C.Str1 /= "abcde" or C.S2 /= String10 or
287 C.S1 /= C432003_0.Default_String(1..10)
288 then
289 Report.Failed("Incorrect object values for Object C");
290 end if;
291 end;
292 exception
293 when Constraint_Error =>
294 Report.Failed("Constraint_Error raised for Object C");
295 end;
296
297
298 begin
299 declare
300 D: C432003_0.NT_A1 := -- C_E
301 (C432003_0.Constrained_Subtype with
302 D2 => Report.Ident_Int(5),
303 S2 => String5);
304 begin
305 C432003_0.Avoid_Optimization(D);
306 Report.Failed("Constraint_Error not raised for Object D");
307 end;
308 exception
309 when Constraint_Error =>
310 null; -- Raise of Constraint_Error is expected.
311 end;
312
313
314 begin
315 declare
316 E: C432003_0.NT_A2 := -- OK
317 (C432003_0.Constrained_Subtype with D3 => 10,
318 S2 => String10,
319 S3 => String10);
320 begin
321 C432003_0.Avoid_Optimization(E);
322 if E.D3 /= 10 or E.Acc /= 356 or
323 E.Str1 /= "abcde" or E.S2 /= String10 or
324 E.S3 /= String10 or
325 E.S1 /= C432003_0.Default_String(1..10)
326 then
327 Report.Failed("Incorrect object values for Object E");
328 end if;
329 end;
330 exception
331 when Constraint_Error =>
332 Report.Failed("Constraint_Error raised for Object E");
333 end;
334
335
336 begin
337 declare
338 F: C432003_0.NT_A2 := -- C_E
339 (C432003_0.Constrained_Subtype with
340 D3 => Report.Ident_Int(5),
341 S2 => String5,
342 S3 => String5);
343 begin
344 C432003_0.Avoid_Optimization(F);
345 Report.Failed("Constraint_Error not raised for Object F");
346 end;
347 exception
348 when Constraint_Error =>
349 null; -- Raise of Constraint_Error is expected.
350 end;
351
352
353 begin
354 declare
355 G: C432003_0.NT_B2 := -- OK
356 (C432003_0.ROOT with D3 => 5,
357 Str1 => "cdefg",
358 S2 => String10,
359 S3 => String5);
360 begin
361 C432003_0.Avoid_Optimization(G);
362 if G.D3 /= 5 or G.Acc /= 356 or
363 G.Str1 /= "cdefg" or G.S2 /= String10 or
364 G.S3 /= String5 or
365 G.S1 /= C432003_0.Default_String(1..5)
366 then
367 Report.Failed("Incorrect object values for Object G");
368 end if;
369 end;
370 exception
371 when Constraint_Error =>
372 Report.Failed("Constraint_Error raised for Object G");
373 end;
374
375
376 begin
377 declare
378 H: C432003_0.NT_B3 := -- OK
379 (C432003_0.Unconstrained_Der with D2 => 5,
380 S2 => String5);
381 begin
382 C432003_0.Avoid_Optimization(H);
383 if H.D2 /= 5 or H.Acc /= 356 or
384 H.Str1 /= "abcde" or H.S2 /= String5 or
385 H.S1 /= C432003_0.Default_String(1..10)
386 then
387 Report.Failed("Incorrect object values for Object H");
388 end if;
389 end;
390 exception
391 when Constraint_Error =>
392 Report.Failed("Constraint_Error raised for Object H");
393 end;
394
395
396 begin
397 declare
398 I: C432003_0.NT_B1 := -- C_E
399 (C432003_0.Constrained_Subtype with
400 D2 => Report.Ident_Int(10),
401 S2 => String10);
402 begin
403 C432003_0.Avoid_Optimization(I);
404 Report.Failed("Constraint_Error not raised for Object I");
405 end;
406 exception
407 when Constraint_Error =>
408 null; -- Raise of Constraint_Error is expected.
409 end;
410
411
412 begin
413 declare
414 J: C432003_0.NT_B2 := -- C_E
415 (C432003_0.Constrained_Subtype with
416 D3 => Report.Ident_Int(10),
417 S2 => String10,
418 S3 => String10);
419 begin
420 C432003_0.Avoid_Optimization(J);
421 Report.Failed("Constraint_Error not raised by Object J");
422 end;
423 exception
424 when Constraint_Error =>
425 null; -- Raise of Constraint_Error is expected.
426 end;
427
428
429 begin
430 declare
431 K: C432003_0.NT_B3 := -- OK
432 (C432003_0.Constrained_Subtype with D2 => 5,
433 S2 => String5);
434 begin
435 C432003_0.Avoid_Optimization(K);
436 if K.D2 /= 5 or K.Acc /= 356 or
437 K.Str1 /= "abcde" or K.S2 /= String5 or
438 K.S1 /= C432003_0.Default_String(1..10)
439 then
440 Report.Failed("Incorrect object values for Object K");
441 end if;
442 end;
443 exception
444 when Constraint_Error =>
445 Report.Failed("Constraint_Error raised for Object K");
446 end;
447
448
449 begin
450 declare
451 M: C432003_0.NT_C2 := -- OK
452 (C432003_0.ROOT with D2 => 10,
453 Str1 => "cdefg",
454 Str2 => String5,
455 S2 => String10);
456 begin
457 C432003_0.Avoid_Optimization(M);
458 if M.D2 /= 10 or M.Acc /= 356 or
459 M.Str1 /= "cdefg" or M.S2 /= String10 or
460 M.Str2 /= String5 or
461 M.S1 /= C432003_0.Default_String(1..5)
462 then
463 Report.Failed("Incorrect object values for Object M");
464 end if;
465 end;
466 exception
467 when Constraint_Error =>
468 Report.Failed("Constraint_Error raised for Object M");
469 end;
470
471
472 begin
473 declare
474 O: C432003_0.NT_C1 := -- C_E
475 (C432003_0.Constrained_Subtype with
476 Str2 => Report.Ident_Str(String5));
477 begin
478 C432003_0.Avoid_Optimization(O);
479 Report.Failed("Constraint_Error not raised for Object O");
480 end;
481 exception
482 when Constraint_Error =>
483 null; -- Raise of Constraint_Error is expected.
484 end;
485
486
487 begin
488 declare
489 P: C432003_0.NT_C2 := -- C_E
490 (C432003_0.Constrained_Subtype with
491 D2 => Report.Ident_Int(10),
492 Str2 => String5,
493 S2 => String10);
494 begin
495 C432003_0.Avoid_Optimization(P);
496 Report.Failed("Constraint_Error not raised by Object P");
497 end;
498 exception
499 when Constraint_Error =>
500 null; -- Raise of Constraint_Error is expected.
501 end;
502
503
504 begin
505 declare
506 Q: C432003_0.NT_C3 :=
507 (C432003_0.Constrained_Subtype with Str2 => String5); -- OK
508 begin
509 C432003_0.Avoid_Optimization(Q);
510 if Q.Str2 /= String5 or
511 Q.Acc /= 356 or
512 Q.Str1 /= "abcde" or
513 Q.D1 /= 10 or
514 Q.S1 /= C432003_0.Default_String(1..10)
515 then
516 Report.Failed("Incorrect object values for Object Q");
517 end if;
518 end;
519 exception
520 when Constraint_Error =>
521 Report.Failed("Constraint_Error raised for Object Q");
522 end;
523
524
525 -- The following cases test where a new discriminant corresponds
526 -- to multiple discriminants of the type of the ancestor part.
527
528 begin
529 declare
530 S: C432003_0.Mult_NT_A1 := -- OK
531 (C432003_0.Mult_Unconstr_Der with D3 => 15,
532 S3 => String15);
533 begin
534 C432003_0.Avoid_Optimization(S);
535 if S.S1 /= C432003_0.Default_String(1..15) or
536 S.Str1 /= String8 or
537 S.S2 /= C432003_0.Another_String(1..15) or
538 S.S3 /= String15 or
539 S.D3 /= 15
540 then
541 Report.Failed("Incorrect object values for Object S");
542 end if;
543 end;
544 exception
545 when Constraint_Error =>
546 Report.Failed("Constraint_Error raised for Object S");
547 end;
548
549
550 begin
551 declare
552 U: C432003_0.Mult_NT_A1 := -- C_E
553 (C432003_0.Mult_Constr_Sub1 with
554 D3 => Report.Ident_Int(15),
555 S3 => String15);
556 begin
557 C432003_0.Avoid_Optimization(U);
558 Report.Failed("Constraint_Error not raised for Object U");
559 end;
560 exception
561 when Constraint_Error =>
562 null; -- Raise of Constraint_Error is expected.
563 end;
564
565
566 begin
567 declare
568 V: C432003_0.Mult_NT_A1 := -- OK
569 (C432003_0.Mult_Constr_Sub2 with D3 => 15,
570 S3 => String15);
571 begin
572 C432003_0.Avoid_Optimization(V);
573 if V.D3 /= 15 or
574 V.Str1 /= String8 or
575 V.S3 /= String15 or
576 V.S1 /= C432003_0.Default_String(1..15) or
577 V.S2 /= C432003_0.Another_String(1..15)
578 then
579 Report.Failed("Incorrect object values for Object V");
580 end if;
581 end;
582 exception
583 when Constraint_Error =>
584 Report.Failed("Constraint_Error raised for Object V");
585 end;
586
587
588 exception
589 when others => Report.Failed("Exception raised in Test_Block");
590 end Test_Block;
591
592 Report.Result;
593
594 end C432003;