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