Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c37213l.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 -- C37213L.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 -- OBJECTIVE:
26 -- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN
27 -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE
28 -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A
29 -- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS
30 -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY:
31 -- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND
32 -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT
33 -- IN THE SUBTYPE.
34
35 -- HISTORY:
36 -- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J.
37 -- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY
38 -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL
39 -- PARAMETERS TO THE GENERIC UNITS AND THE
40 -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE
41 -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE
42 -- ARE TOGETHER; REWROTE ONE OF THE GENERIC
43 -- PACKAGES AS A GENERIC PROCEDURE TO BROADEN
44 -- COVERAGE OF TEST.
45
46 WITH REPORT; USE REPORT;
47 PROCEDURE C37213L IS
48 BEGIN
49 TEST ("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " &
50 "OR AN INDEX CONSTRAINT THAT DEPEND ON A " &
51 "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " &
52 "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " &
53 "USED AS THE ACTUAL PARAMETER TO A GENERIC " &
54 "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " &
55 "ACCESS TYPE");
56
57 DECLARE
58 SUBTYPE SM IS INTEGER RANGE 1..10;
59 TYPE REC (D1, D2 : SM) IS
60 RECORD NULL; END RECORD;
61 TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
62
63 SEQUENCE_NUMBER : INTEGER;
64
65 GENERIC
66 TYPE CONS IS PRIVATE;
67 OBJ_XCP : BOOLEAN;
68 TAG : STRING;
69 PACKAGE DER_CHK IS END DER_CHK;
70
71 PACKAGE BODY DER_CHK IS
72 BEGIN
73 DECLARE
74 TYPE DREC IS NEW CONS;
75 BEGIN
76 DECLARE
77 X : DREC;
78
79 FUNCTION VALUE RETURN DREC IS
80 BEGIN
81 IF EQUAL (3,3) THEN
82 RETURN X;
83 ELSE
84 RETURN X;
85 END IF;
86 END VALUE;
87 BEGIN
88 IF OBJ_XCP THEN
89 FAILED ("NO CHECK DURING DECLARATION " &
90 "OF OBJECT OF TYPE DREC - " &
91 TAG);
92 ELSIF X /= VALUE THEN
93 FAILED ("INCORRECT VALUE FOR OBJECT OF " &
94 "TYPE DREC - " & TAG);
95 END IF;
96 END;
97 EXCEPTION
98 WHEN CONSTRAINT_ERROR =>
99 IF NOT OBJ_XCP THEN
100 FAILED ("IMPROPER CONSTRAINT CHECKED " &
101 "DURING DECLARATION OF OBJECT " &
102 "OF TYPE DREC - " & TAG);
103 END IF;
104 END;
105 EXCEPTION
106 WHEN CONSTRAINT_ERROR =>
107 FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
108 "DURING DECLARATION OF DREC - " & TAG);
109 END;
110
111 GENERIC
112 TYPE CONS IS PRIVATE;
113 PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
114 TAG : STRING);
115
116 PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN;
117 TAG : STRING) IS
118 BEGIN
119 DECLARE
120 TYPE ACC_CONS IS ACCESS CONS;
121 BEGIN
122 DECLARE
123 X : ACC_CONS;
124
125 FUNCTION VALUE RETURN CONS IS
126 BEGIN
127 IF EQUAL (5, 5) THEN
128 RETURN X.ALL;
129 ELSE
130 RETURN X.ALL;
131 END IF;
132 END VALUE;
133 BEGIN
134 X := NEW CONS;
135
136 IF OBJ_XCP THEN
137 FAILED ("NO CHECK DURING ALLOCATION " &
138 "OF OBJECT OF TYPE CONS - " &
139 TAG);
140 ELSIF X.ALL /= VALUE THEN
141 FAILED ("INCORRECT VALUE FOR OBJECT " &
142 "OF TYPE CONS - " & TAG);
143 END IF;
144 EXCEPTION
145 WHEN CONSTRAINT_ERROR =>
146 IF NOT OBJ_XCP THEN
147 FAILED ("IMPROPER CONSTRAINT " &
148 "CHECKED DURING " &
149 "ALLOCATION OF OBJECT " &
150 "OF TYPE CONS - " & TAG);
151 END IF;
152 END;
153 EXCEPTION
154 WHEN CONSTRAINT_ERROR =>
155 FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
156 "DURING DECLARATION OF X - " & TAG);
157 END;
158 EXCEPTION
159 WHEN CONSTRAINT_ERROR =>
160 FAILED ("CONSTRAINT IMPROPERLY CHECKED " &
161 "DURING DECLARATION OF ACC_CONS - " & TAG);
162 END ACC_CHK;
163 BEGIN
164 SEQUENCE_NUMBER := 1;
165 DECLARE
166 TYPE REC_DEF (D3 : INTEGER := 1) IS
167 RECORD
168 C1 : REC (D3, 0);
169 END RECORD;
170
171 PACKAGE PACK1 IS NEW DER_CHK (REC_DEF,
172 OBJ_XCP => TRUE,
173 TAG => "PACK1");
174
175 PROCEDURE PROC1 IS NEW ACC_CHK (REC_DEF);
176 BEGIN
177 PROC1 (OBJ_XCP => TRUE, TAG => "PROC1");
178 END;
179
180 SEQUENCE_NUMBER := 2;
181 DECLARE
182 TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS
183 RECORD
184 C1 : MY_ARR (0..D3);
185 END RECORD;
186
187 PACKAGE PACK2 IS NEW DER_CHK (ARR_DEF,
188 OBJ_XCP => TRUE,
189 TAG => "PACK2");
190
191 PROCEDURE PROC2 IS NEW ACC_CHK (ARR_DEF);
192 BEGIN
193 PROC2 (OBJ_XCP => TRUE, TAG => "PROC2");
194 END;
195
196 SEQUENCE_NUMBER := 3;
197 DECLARE
198 TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS
199 RECORD
200 CASE D3 IS
201 WHEN -5..10 =>
202 C1 : REC (D3, IDENT_INT(11));
203 WHEN OTHERS =>
204 C2 : INTEGER := IDENT_INT(5);
205 END CASE;
206 END RECORD;
207
208 PACKAGE PACK3 IS NEW DER_CHK (VAR_REC_DEF1,
209 OBJ_XCP => TRUE,
210 TAG => "PACK3");
211
212 PROCEDURE PROC3 IS NEW ACC_CHK (VAR_REC_DEF1);
213 BEGIN
214 PROC3 (OBJ_XCP => TRUE, TAG => "PROC3");
215 END;
216
217 SEQUENCE_NUMBER := 4;
218 DECLARE
219 TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS
220 RECORD
221 CASE D3 IS
222 WHEN -5..10 =>
223 C1 : REC (D3, IDENT_INT(11));
224 WHEN OTHERS =>
225 C2 : INTEGER := IDENT_INT(5);
226 END CASE;
227 END RECORD;
228
229 PACKAGE PACK4 IS NEW DER_CHK (VAR_REC_DEF6,
230 OBJ_XCP => FALSE,
231 TAG => "PACK4");
232
233 PROCEDURE PROC4 IS NEW ACC_CHK (VAR_REC_DEF6);
234 BEGIN
235 PROC4 (OBJ_XCP => FALSE, TAG => "PROC4");
236 END;
237
238 SEQUENCE_NUMBER := 5;
239 DECLARE
240 TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS
241 RECORD
242 CASE D3 IS
243 WHEN -5..10 =>
244 C1 : REC (D3, IDENT_INT(11));
245 WHEN OTHERS =>
246 C2 : INTEGER := IDENT_INT(5);
247 END CASE;
248 END RECORD;
249
250 PACKAGE PACK5 IS NEW DER_CHK (VAR_REC_DEF11,
251 OBJ_XCP => FALSE,
252 TAG => "PACK5");
253
254 PROCEDURE PROC5 IS NEW ACC_CHK (VAR_REC_DEF11);
255 BEGIN
256 PROC5 (OBJ_XCP => FALSE, TAG => "PROC5");
257 END;
258
259 SEQUENCE_NUMBER := 6;
260 DECLARE
261 TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS
262 RECORD
263 CASE D3 IS
264 WHEN -5..10 =>
265 C1 : MY_ARR(D3..IDENT_INT(11));
266 WHEN OTHERS =>
267 C2 : INTEGER := IDENT_INT(5);
268 END CASE;
269 END RECORD;
270
271 PACKAGE PACK6 IS NEW DER_CHK (VAR_ARR_DEF1,
272 OBJ_XCP => TRUE,
273 TAG => "PACK6");
274
275 PROCEDURE PROC6 IS NEW ACC_CHK (VAR_ARR_DEF1);
276 BEGIN
277 PROC6 (OBJ_XCP => TRUE, TAG => "PROC6");
278 END;
279
280 SEQUENCE_NUMBER := 7;
281 DECLARE
282 TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS
283 RECORD
284 CASE D3 IS
285 WHEN -5..10 =>
286 C1 : MY_ARR(D3..IDENT_INT(11));
287 WHEN OTHERS =>
288 C2 : INTEGER := IDENT_INT(5);
289 END CASE;
290 END RECORD;
291
292 PACKAGE PACK7 IS NEW DER_CHK (VAR_ARR_DEF6,
293 OBJ_XCP => FALSE,
294 TAG => "PACK7");
295
296 PROCEDURE PROC7 IS NEW ACC_CHK (VAR_ARR_DEF6);
297 BEGIN
298 PROC7 (OBJ_XCP => FALSE, TAG => "PROC7");
299 END;
300
301 SEQUENCE_NUMBER := 8;
302 DECLARE
303 TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS
304 RECORD
305 CASE D3 IS
306 WHEN -5..10 =>
307 C1 : MY_ARR(D3..IDENT_INT(11));
308 WHEN OTHERS =>
309 C2 : INTEGER := IDENT_INT(5);
310 END CASE;
311 END RECORD;
312
313 PACKAGE PACK8 IS NEW DER_CHK (VAR_ARR_DEF11,
314 OBJ_XCP => FALSE,
315 TAG => "PACK8");
316
317 PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11);
318 BEGIN
319 PROC8 (OBJ_XCP => FALSE, TAG => "PROC8");
320 END;
321 EXCEPTION
322 WHEN OTHERS =>
323 FAILED ("UNEXPECTED EXCEPTION RAISED DURING " &
324 "DECLARATION / INSTANTIATION ELABORATION - " &
325 INTEGER'IMAGE (SEQUENCE_NUMBER));
326 END;
327
328 RESULT;
329 END C37213L;