|
111
|
1 -- C34005P.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 ONE-DIMENSIONAL ARRAY TYPES WHOSE
|
|
|
28 -- COMPONENT TYPE IS A LIMITED TYPE.
|
|
|
29
|
|
|
30 -- HISTORY:
|
|
|
31 -- JRK 08/17/87 CREATED ORIGINAL TEST.
|
|
|
32 -- VCL 07/01/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE
|
|
|
33 -- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE
|
|
|
34 -- SIZES. ADDED EXCEPTION HANDLERS TO CATCH INCORRECT
|
|
|
35 -- TYPE CONVERSIONS TO DERIVED SUBTYPES.
|
|
|
36 -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
|
|
|
37 -- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
|
|
|
38 -- SUPPORTING CODE.
|
|
|
39
|
|
|
40 WITH SYSTEM; USE SYSTEM;
|
|
|
41 WITH REPORT; USE REPORT;
|
|
|
42
|
|
|
43 PROCEDURE C34005P IS
|
|
|
44
|
|
|
45 PACKAGE PKG_L IS
|
|
|
46
|
|
|
47 TYPE LP IS LIMITED PRIVATE;
|
|
|
48
|
|
|
49 FUNCTION CREATE (X : INTEGER) RETURN LP;
|
|
|
50
|
|
|
51 FUNCTION VALUE (X : LP) RETURN INTEGER;
|
|
|
52
|
|
|
53 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
|
|
|
54
|
|
|
55 PROCEDURE ASSIGN (X : OUT LP; Y : LP);
|
|
|
56
|
|
|
57 C1 : CONSTANT LP;
|
|
|
58 C2 : CONSTANT LP;
|
|
|
59 C3 : CONSTANT LP;
|
|
|
60 C4 : CONSTANT LP;
|
|
|
61 C5 : CONSTANT LP;
|
|
|
62 C6 : CONSTANT LP;
|
|
|
63
|
|
|
64 PRIVATE
|
|
|
65
|
|
|
66 TYPE LP IS NEW INTEGER;
|
|
|
67
|
|
|
68 C1 : CONSTANT LP := 1;
|
|
|
69 C2 : CONSTANT LP := 2;
|
|
|
70 C3 : CONSTANT LP := 3;
|
|
|
71 C4 : CONSTANT LP := 4;
|
|
|
72 C5 : CONSTANT LP := 5;
|
|
|
73 C6 : CONSTANT LP := 6;
|
|
|
74
|
|
|
75 END PKG_L;
|
|
|
76
|
|
|
77 USE PKG_L;
|
|
|
78
|
|
|
79 SUBTYPE COMPONENT IS LP;
|
|
|
80
|
|
|
81 PACKAGE PKG_P IS
|
|
|
82
|
|
|
83 FIRST : CONSTANT := 0;
|
|
|
84 LAST : CONSTANT := 100;
|
|
|
85
|
|
|
86 SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
|
|
|
87
|
|
|
88 TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
|
|
|
89
|
|
|
90 FUNCTION CREATE ( F, L : INDEX;
|
|
|
91 C : COMPONENT;
|
|
|
92 DUMMY : PARENT -- TO RESOLVE OVERLOADING.
|
|
|
93 ) RETURN PARENT;
|
|
|
94
|
|
|
95 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
|
|
|
96
|
|
|
97 FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT;
|
|
|
98
|
|
|
99 FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT;
|
|
|
100
|
|
|
101 END PKG_P;
|
|
|
102
|
|
|
103 USE PKG_P;
|
|
|
104
|
|
|
105 TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
|
|
|
106
|
|
|
107 X : T;
|
|
|
108 W : PARENT (5 .. 7);
|
|
|
109 C : COMPONENT;
|
|
|
110 B : BOOLEAN := FALSE;
|
|
|
111 N : CONSTANT := 1;
|
|
|
112
|
|
|
113 PROCEDURE A (X : ADDRESS) IS
|
|
|
114 BEGIN
|
|
|
115 B := IDENT_BOOL (TRUE);
|
|
|
116 END A;
|
|
|
117
|
|
|
118 FUNCTION V RETURN T IS
|
|
|
119 RESULT : T;
|
|
|
120 BEGIN
|
|
|
121 FOR I IN RESULT'RANGE LOOP
|
|
|
122 ASSIGN (RESULT (I), C);
|
|
|
123 END LOOP;
|
|
|
124 RETURN RESULT;
|
|
|
125 END V;
|
|
|
126
|
|
|
127 PACKAGE BODY PKG_L IS
|
|
|
128
|
|
|
129 FUNCTION CREATE (X : INTEGER) RETURN LP IS
|
|
|
130 BEGIN
|
|
|
131 RETURN LP (IDENT_INT (X));
|
|
|
132 END CREATE;
|
|
|
133
|
|
|
134 FUNCTION VALUE (X : LP) RETURN INTEGER IS
|
|
|
135 BEGIN
|
|
|
136 RETURN INTEGER (X);
|
|
|
137 END VALUE;
|
|
|
138
|
|
|
139 FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
|
|
|
140 BEGIN
|
|
|
141 RETURN X = Y;
|
|
|
142 END EQUAL;
|
|
|
143
|
|
|
144 PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
|
|
|
145 BEGIN
|
|
|
146 X := Y;
|
|
|
147 END ASSIGN;
|
|
|
148
|
|
|
149 END PKG_L;
|
|
|
150
|
|
|
151 PACKAGE BODY PKG_P IS
|
|
|
152
|
|
|
153 FUNCTION CREATE
|
|
|
154 ( F, L : INDEX;
|
|
|
155 C : COMPONENT;
|
|
|
156 DUMMY : PARENT
|
|
|
157 ) RETURN PARENT
|
|
|
158 IS
|
|
|
159 A : PARENT (F .. L);
|
|
|
160 B : COMPONENT;
|
|
|
161 BEGIN
|
|
|
162 ASSIGN (B, C);
|
|
|
163 FOR I IN F .. L LOOP
|
|
|
164 ASSIGN (A (I), B);
|
|
|
165 ASSIGN (B, CREATE (VALUE (B) + 1));
|
|
|
166 END LOOP;
|
|
|
167 RETURN A;
|
|
|
168 END CREATE;
|
|
|
169
|
|
|
170 FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
|
|
|
171 BEGIN
|
|
|
172 IF X'LENGTH /= Y'LENGTH THEN
|
|
|
173 RETURN FALSE;
|
|
|
174 ELSE FOR I IN X'RANGE LOOP
|
|
|
175 IF NOT EQUAL (X (I),
|
|
|
176 Y (I - X'FIRST + Y'FIRST)) THEN
|
|
|
177 RETURN FALSE;
|
|
|
178 END IF;
|
|
|
179 END LOOP;
|
|
|
180 END IF;
|
|
|
181 RETURN TRUE;
|
|
|
182 END EQUAL;
|
|
|
183
|
|
|
184 FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS
|
|
|
185 RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1);
|
|
|
186 BEGIN
|
|
|
187 ASSIGN (RESULT (INDEX'FIRST ), X);
|
|
|
188 ASSIGN (RESULT (INDEX'FIRST + 1), Y);
|
|
|
189 RETURN RESULT;
|
|
|
190 END AGGR;
|
|
|
191
|
|
|
192 FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT IS
|
|
|
193 RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 2);
|
|
|
194 BEGIN
|
|
|
195 ASSIGN (RESULT (INDEX'FIRST ), X);
|
|
|
196 ASSIGN (RESULT (INDEX'FIRST + 1), Y);
|
|
|
197 ASSIGN (RESULT (INDEX'FIRST + 2), Z);
|
|
|
198 RETURN RESULT;
|
|
|
199 END AGGR;
|
|
|
200
|
|
|
201 END PKG_P;
|
|
|
202
|
|
|
203 BEGIN
|
|
|
204 TEST ("C34005P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
|
|
|
205 "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
|
|
|
206 "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
|
|
|
207 "TYPE IS A LIMITED TYPE");
|
|
|
208
|
|
|
209 ASSIGN (X (IDENT_INT (5)), CREATE (1));
|
|
|
210 ASSIGN (X (IDENT_INT (6)), CREATE (2));
|
|
|
211 ASSIGN (X (IDENT_INT (7)), CREATE (3));
|
|
|
212
|
|
|
213 ASSIGN (W (5), CREATE (1));
|
|
|
214 ASSIGN (W (6), CREATE (2));
|
|
|
215 ASSIGN (W (7), CREATE (3));
|
|
|
216
|
|
|
217 ASSIGN (C, CREATE (2));
|
|
|
218
|
|
|
219 IF NOT EQUAL (T'(X), AGGR (C1, C2, C3)) THEN
|
|
|
220 FAILED ("INCORRECT QUALIFICATION");
|
|
|
221 END IF;
|
|
|
222
|
|
|
223 IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN
|
|
|
224 FAILED ("INCORRECT SELF CONVERSION");
|
|
|
225 END IF;
|
|
|
226
|
|
|
227 IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN
|
|
|
228 FAILED ("INCORRECT CONVERSION FROM PARENT");
|
|
|
229 END IF;
|
|
|
230
|
|
|
231 IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN
|
|
|
232 FAILED ("INCORRECT CONVERSION TO PARENT - 1");
|
|
|
233 END IF;
|
|
|
234
|
|
|
235 BEGIN
|
|
|
236 IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)),
|
|
|
237 AGGR (C4, C5)) THEN
|
|
|
238 FAILED ("INCORRECT CONVERSION TO PARENT - 2");
|
|
|
239 END IF;
|
|
|
240 EXCEPTION
|
|
|
241 WHEN OTHERS =>
|
|
|
242 FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
|
|
|
243 "VALUES OUTSIDE OF THE SUBTYPE T - 1");
|
|
|
244 END;
|
|
|
245
|
|
|
246 IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN
|
|
|
247 FAILED ("INCORRECT INDEX (VALUE)");
|
|
|
248 END IF;
|
|
|
249
|
|
|
250 BEGIN
|
|
|
251 IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
|
|
|
252 AGGR (C2, C3)) OR
|
|
|
253 NOT EQUAL (CREATE (1, 4, C4, X)(1..3),
|
|
|
254 AGGR (C4, C5, C6)) THEN
|
|
|
255 FAILED ("INCORRECT SLICE (VALUE)");
|
|
|
256 END IF;
|
|
|
257 EXCEPTION
|
|
|
258 WHEN OTHERS =>
|
|
|
259 FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES");
|
|
|
260 END;
|
|
|
261
|
|
|
262 IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN
|
|
|
263 FAILED ("INCORRECT ""IN""");
|
|
|
264 END IF;
|
|
|
265
|
|
|
266 IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN
|
|
|
267 FAILED ("INCORRECT ""NOT IN""");
|
|
|
268 END IF;
|
|
|
269
|
|
|
270 B := FALSE;
|
|
|
271 A (X'ADDRESS);
|
|
|
272 IF NOT B THEN
|
|
|
273 FAILED ("INCORRECT 'ADDRESS");
|
|
|
274 END IF;
|
|
|
275
|
|
|
276 IF T'FIRST /= 5 THEN
|
|
|
277 FAILED ("INCORRECT TYPE'FIRST");
|
|
|
278 END IF;
|
|
|
279
|
|
|
280 IF X'FIRST /= 5 THEN
|
|
|
281 FAILED ("INCORRECT OBJECT'FIRST");
|
|
|
282 END IF;
|
|
|
283
|
|
|
284 IF V'FIRST /= 5 THEN
|
|
|
285 FAILED ("INCORRECT VALUE'FIRST");
|
|
|
286 END IF;
|
|
|
287
|
|
|
288 IF T'FIRST (N) /= 5 THEN
|
|
|
289 FAILED ("INCORRECT TYPE'FIRST (N)");
|
|
|
290 END IF;
|
|
|
291
|
|
|
292 IF X'FIRST (N) /= 5 THEN
|
|
|
293 FAILED ("INCORRECT OBJECT'FIRST (N)");
|
|
|
294 END IF;
|
|
|
295
|
|
|
296 IF V'FIRST (N) /= 5 THEN
|
|
|
297 FAILED ("INCORRECT VALUE'FIRST (N)");
|
|
|
298 END IF;
|
|
|
299
|
|
|
300 IF T'LAST /= 7 THEN
|
|
|
301 FAILED ("INCORRECT TYPE'LAST");
|
|
|
302 END IF;
|
|
|
303
|
|
|
304 IF X'LAST /= 7 THEN
|
|
|
305 FAILED ("INCORRECT OBJECT'LAST");
|
|
|
306 END IF;
|
|
|
307
|
|
|
308 IF V'LAST /= 7 THEN
|
|
|
309 FAILED ("INCORRECT VALUE'LAST");
|
|
|
310 END IF;
|
|
|
311
|
|
|
312 IF T'LAST (N) /= 7 THEN
|
|
|
313 FAILED ("INCORRECT TYPE'LAST (N)");
|
|
|
314 END IF;
|
|
|
315
|
|
|
316 IF X'LAST (N) /= 7 THEN
|
|
|
317 FAILED ("INCORRECT OBJECT'LAST (N)");
|
|
|
318 END IF;
|
|
|
319
|
|
|
320 IF V'LAST (N) /= 7 THEN
|
|
|
321 FAILED ("INCORRECT VALUE'LAST (N)");
|
|
|
322 END IF;
|
|
|
323
|
|
|
324 IF T'LENGTH /= 3 THEN
|
|
|
325 FAILED ("INCORRECT TYPE'LENGTH");
|
|
|
326 END IF;
|
|
|
327
|
|
|
328 IF X'LENGTH /= 3 THEN
|
|
|
329 FAILED ("INCORRECT OBJECT'LENGTH");
|
|
|
330 END IF;
|
|
|
331
|
|
|
332 IF V'LENGTH /= 3 THEN
|
|
|
333 FAILED ("INCORRECT VALUE'LENGTH");
|
|
|
334 END IF;
|
|
|
335
|
|
|
336 IF T'LENGTH (N) /= 3 THEN
|
|
|
337 FAILED ("INCORRECT TYPE'LENGTH (N)");
|
|
|
338 END IF;
|
|
|
339
|
|
|
340 IF X'LENGTH (N) /= 3 THEN
|
|
|
341 FAILED ("INCORRECT OBJECT'LENGTH (N)");
|
|
|
342 END IF;
|
|
|
343
|
|
|
344 IF V'LENGTH (N) /= 3 THEN
|
|
|
345 FAILED ("INCORRECT VALUE'LENGTH (N)");
|
|
|
346 END IF;
|
|
|
347
|
|
|
348 DECLARE
|
|
|
349 Y : PARENT (T'RANGE);
|
|
|
350 BEGIN
|
|
|
351 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
352 FAILED ("INCORRECT TYPE'RANGE");
|
|
|
353 END IF;
|
|
|
354 END;
|
|
|
355
|
|
|
356 DECLARE
|
|
|
357 Y : PARENT (X'RANGE);
|
|
|
358 BEGIN
|
|
|
359 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
360 FAILED ("INCORRECT OBJECT'RANGE");
|
|
|
361 END IF;
|
|
|
362 END;
|
|
|
363
|
|
|
364 DECLARE
|
|
|
365 Y : PARENT (V'RANGE);
|
|
|
366 BEGIN
|
|
|
367 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
368 FAILED ("INCORRECT VALUE'RANGE");
|
|
|
369 END IF;
|
|
|
370 END;
|
|
|
371
|
|
|
372 DECLARE
|
|
|
373 Y : PARENT (T'RANGE (N));
|
|
|
374 BEGIN
|
|
|
375 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
376 FAILED ("INCORRECT TYPE'RANGE (N)");
|
|
|
377 END IF;
|
|
|
378 END;
|
|
|
379
|
|
|
380 DECLARE
|
|
|
381 Y : PARENT (X'RANGE (N));
|
|
|
382 BEGIN
|
|
|
383 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
384 FAILED ("INCORRECT OBJECT'RANGE (N)");
|
|
|
385 END IF;
|
|
|
386 END;
|
|
|
387
|
|
|
388 DECLARE
|
|
|
389 Y : PARENT (V'RANGE (N));
|
|
|
390 BEGIN
|
|
|
391 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
|
|
|
392 FAILED ("INCORRECT VALUE'RANGE (N)");
|
|
|
393 END IF;
|
|
|
394 END;
|
|
|
395
|
|
|
396 IF X'SIZE < T'SIZE THEN
|
|
|
397 COMMENT ("X'SIZE < T'SIZE");
|
|
|
398 ELSIF X'SIZE = T'SIZE THEN
|
|
|
399 COMMENT ("X'SIZE = T'SIZE");
|
|
|
400 ELSE
|
|
|
401 COMMENT ("X'SIZE > T'SIZE");
|
|
|
402 END IF;
|
|
|
403
|
|
|
404 RESULT;
|
|
|
405 END C34005P;
|
