Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34006j.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 -- C34006J.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 THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27 -- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH
28 -- A LIMITED COMPONENT TYPE.
29
30 -- HISTORY:
31 -- JRK 08/25/87 CREATED ORIGINAL TEST.
32 -- VCL 06/28/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
33 -- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
34 -- SIZES.
35 -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
36
37 WITH SYSTEM; USE SYSTEM;
38 WITH REPORT; USE REPORT;
39
40 PROCEDURE C34006J IS
41
42 PACKAGE PKG_L IS
43
44 TYPE LP IS LIMITED PRIVATE;
45
46 FUNCTION CREATE (X : INTEGER) RETURN LP;
47
48 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
49
50 PROCEDURE ASSIGN (X : OUT LP; Y : LP);
51
52 C4 : CONSTANT LP;
53 C5 : CONSTANT LP;
54
55 PRIVATE
56
57 TYPE LP IS NEW INTEGER;
58
59 C4 : CONSTANT LP := 4;
60 C5 : CONSTANT LP := 5;
61
62 END PKG_L;
63
64 USE PKG_L;
65
66 SUBTYPE COMPONENT IS LP;
67
68 PACKAGE PKG_P IS
69
70 MAX_LEN : CONSTANT := 10;
71
72 SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN;
73
74 TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS
75 RECORD
76 I : INTEGER := 2;
77 CASE B IS
78 WHEN TRUE =>
79 S : STRING (1 .. L) := (1 .. L => 'A');
80 C : COMPONENT;
81 WHEN FALSE =>
82 F : FLOAT := 5.0;
83 END CASE;
84 END RECORD;
85
86 FUNCTION CREATE ( B : BOOLEAN;
87 L : LENGTH;
88 I : INTEGER;
89 S : STRING;
90 C : COMPONENT;
91 F : FLOAT;
92 X : PARENT -- TO RESOLVE OVERLOADING.
93 ) RETURN PARENT;
94
95 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
96
97 FUNCTION AGGR ( B : BOOLEAN;
98 L : LENGTH;
99 I : INTEGER;
100 S : STRING;
101 C : COMPONENT
102 ) RETURN PARENT;
103
104 FUNCTION AGGR ( B : BOOLEAN;
105 L : LENGTH;
106 I : INTEGER;
107 F : FLOAT
108 ) RETURN PARENT;
109
110 END PKG_P;
111
112 USE PKG_P;
113
114 TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3));
115
116 X : T;
117 W : PARENT;
118 B : BOOLEAN := FALSE;
119
120 PROCEDURE A (X : ADDRESS) IS
121 BEGIN
122 B := IDENT_BOOL (TRUE);
123 END A;
124
125 PACKAGE BODY PKG_L IS
126
127 FUNCTION CREATE (X : INTEGER) RETURN LP IS
128 BEGIN
129 RETURN LP (IDENT_INT (X));
130 END CREATE;
131
132 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
133 BEGIN
134 RETURN X = Y;
135 END EQUAL;
136
137 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
138 BEGIN
139 X := Y;
140 END ASSIGN;
141
142 END PKG_L;
143
144 PACKAGE BODY PKG_P IS
145
146 FUNCTION CREATE
147 ( B : BOOLEAN;
148 L : LENGTH;
149 I : INTEGER;
150 S : STRING;
151 C : COMPONENT;
152 F : FLOAT;
153 X : PARENT
154 ) RETURN PARENT
155 IS
156 A : PARENT (B, L);
157 BEGIN
158 A.I := I;
159 CASE B IS
160 WHEN TRUE =>
161 A.S := S;
162 ASSIGN (A.C, C);
163 WHEN FALSE =>
164 A.F := F;
165 END CASE;
166 RETURN A;
167 END CREATE;
168
169 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
170 BEGIN
171 IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN
172 RETURN FALSE;
173 END IF;
174 CASE X.B IS
175 WHEN TRUE =>
176 RETURN X.S = Y.S AND EQUAL (X.C, Y.C);
177 WHEN FALSE =>
178 RETURN X.F = Y.F;
179 END CASE;
180 END EQUAL;
181
182 FUNCTION AGGR
183 ( B : BOOLEAN;
184 L : LENGTH;
185 I : INTEGER;
186 S : STRING;
187 C : COMPONENT
188 ) RETURN PARENT
189 IS
190 RESULT : PARENT (B, L);
191 BEGIN
192 RESULT.I := I;
193 RESULT.S := S;
194 ASSIGN (RESULT.C, C);
195 RETURN RESULT;
196 END AGGR;
197
198 FUNCTION AGGR
199 ( B : BOOLEAN;
200 L : LENGTH;
201 I : INTEGER;
202 F : FLOAT
203 ) RETURN PARENT
204 IS
205 RESULT : PARENT (B, L);
206 BEGIN
207 RESULT.I := I;
208 RESULT.F := F;
209 RETURN RESULT;
210 END AGGR;
211
212 END PKG_P;
213
214 BEGIN
215 TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
216 "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
217 "RECORD TYPES WITH DISCRIMINANTS AND WITH A " &
218 "LIMITED COMPONENT TYPE");
219
220 X.I := IDENT_INT (1);
221 X.S := IDENT_STR ("ABC");
222 ASSIGN (X.C, CREATE (4));
223
224 W.I := IDENT_INT (1);
225 W.S := IDENT_STR ("ABC");
226 ASSIGN (W.C, CREATE (4));
227
228 IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
229 FAILED ("INCORRECT QUALIFICATION");
230 END IF;
231
232 IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
233 FAILED ("INCORRECT SELF CONVERSION");
234 END IF;
235
236 IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN
237 FAILED ("INCORRECT CONVERSION FROM PARENT");
238 END IF;
239
240 IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4)) OR
241 NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)),
242 AGGR (FALSE, 2, 3, 6.0)) THEN
243 FAILED ("INCORRECT CONVERSION TO PARENT");
244 END IF;
245
246 IF X.B /= TRUE OR X.L /= 3 OR
247 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR
248 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN
249 FAILED ("INCORRECT SELECTION (DISCRIMINANT)");
250 END IF;
251
252 IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR
253 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR
254 CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN
255 FAILED ("INCORRECT SELECTION (VALUE)");
256 END IF;
257
258 X.I := IDENT_INT (7);
259 X.S := IDENT_STR ("XYZ");
260 IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN
261 FAILED ("INCORRECT SELECTION (ASSIGNMENT)");
262 END IF;
263
264 X.I := IDENT_INT (1);
265 X.S := IDENT_STR ("ABC");
266 IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN
267 FAILED ("INCORRECT ""IN""");
268 END IF;
269
270 IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN
271 FAILED ("INCORRECT ""NOT IN""");
272 END IF;
273
274 B := FALSE;
275 A (X'ADDRESS);
276 IF NOT B THEN
277 FAILED ("INCORRECT 'ADDRESS");
278 END IF;
279
280 IF NOT X'CONSTRAINED THEN
281 FAILED ("INCORRECT 'CONSTRAINED");
282 END IF;
283
284 IF X.C'FIRST_BIT < 0 THEN
285 FAILED ("INCORRECT 'FIRST_BIT");
286 END IF;
287
288 IF X.C'LAST_BIT < 0 OR
289 X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN
290 FAILED ("INCORRECT 'LAST_BIT");
291 END IF;
292
293 IF X.C'POSITION < 0 THEN
294 FAILED ("INCORRECT 'POSITION");
295 END IF;
296
297 IF X'SIZE < T'SIZE THEN
298 COMMENT ("X'SIZE < T'SIZE");
299 ELSIF X'SIZE = T'SIZE THEN
300 COMMENT ("X'SIZE = T'SIZE");
301 ELSE
302 COMMENT ("X'SIZE > T'SIZE");
303 END IF;
304
305 RESULT;
306 EXCEPTION
307 WHEN OTHERS =>
308 FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " &
309 "OPERATIONS");
310 RESULT;
311 END C34006J;