3 -- Grant of Unlimited Rights
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
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.
26 -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27 -- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE
28 -- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 1 OF 2
29 -- TESTS WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST
33 -- JRK 08/20/87 CREATED ORIGINAL TEST.
34 -- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34005S.ADA AND
36 -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
38 WITH SYSTEM
; USE SYSTEM
;
39 WITH REPORT
; USE REPORT
;
45 TYPE LP
IS LIMITED PRIVATE;
47 FUNCTION CREATE
(X
: INTEGER) RETURN LP
;
49 FUNCTION VALUE
(X
: LP
) RETURN INTEGER;
51 FUNCTION EQUAL
(X
, Y
: LP
) RETURN BOOLEAN;
53 PROCEDURE ASSIGN
(X
: OUT LP
; Y
: LP
);
72 TYPE LP
IS NEW INTEGER;
74 C1
: CONSTANT LP
:= 1;
75 C2
: CONSTANT LP
:= 2;
76 C3
: CONSTANT LP
:= 3;
77 C4
: CONSTANT LP
:= 4;
78 C5
: CONSTANT LP
:= 5;
79 C6
: CONSTANT LP
:= 6;
80 C7
: CONSTANT LP
:= 7;
81 C8
: CONSTANT LP
:= 8;
82 C9
: CONSTANT LP
:= 9;
83 C10
: CONSTANT LP
:= 10;
84 C11
: CONSTANT LP
:= 11;
85 C12
: CONSTANT LP
:= 12;
86 C13
: CONSTANT LP
:= 13;
87 C14
: CONSTANT LP
:= 14;
93 SUBTYPE COMPONENT
IS LP
;
97 FIRST
: CONSTANT := 0;
98 LAST
: CONSTANT := 10;
100 SUBTYPE INDEX
IS INTEGER RANGE FIRST
.. LAST
;
102 TYPE PARENT
IS ARRAY (INDEX
RANGE <>, INDEX
RANGE <>) OF
105 FUNCTION CREATE
( F1
, L1
: INDEX
;
108 DUMMY
: PARENT
-- TO RESOLVE OVERLOADING.
111 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN;
117 TYPE T
IS NEW PARENT
(IDENT_INT
(4) .. IDENT_INT
(5),
118 IDENT_INT
(6) .. IDENT_INT
(8));
120 TYPE ARRT
IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
123 SUBTYPE ARR
IS ARRT
(8 .. 9, 2 .. 4);
126 W
: PARENT
(4 .. 5, 6 .. 8);
128 B
: BOOLEAN := FALSE;
132 PROCEDURE A
(X
: ADDRESS
) IS
134 B
:= IDENT_BOOL
(TRUE);
137 FUNCTION V
RETURN T
IS
140 FOR I
IN RESULT
'RANGE LOOP
141 FOR J
IN RESULT
'RANGE(2) LOOP
142 ASSIGN
(RESULT
(I
, J
), C
);
148 PACKAGE BODY PKG_L
IS
150 FUNCTION CREATE
(X
: INTEGER) RETURN LP
IS
152 RETURN LP
(IDENT_INT
(X
));
155 FUNCTION VALUE
(X
: LP
) RETURN INTEGER IS
160 FUNCTION EQUAL
(X
, Y
: LP
) RETURN BOOLEAN IS
165 PROCEDURE ASSIGN
(X
: OUT LP
; Y
: LP
) IS
172 PACKAGE BODY PKG_P
IS
181 A
: PARENT
(F1
.. L1
, F2
.. L2
);
185 FOR I
IN F1
.. L1
LOOP
186 FOR J
IN F2
.. L2
LOOP
187 ASSIGN
(A
(I
, J
), B
);
188 ASSIGN
(B
, CREATE
(VALUE
(B
) + 1));
194 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN IS
196 IF X
'LENGTH /= Y
'LENGTH OR
197 X
'LENGTH(2) /= Y
'LENGTH(2) THEN
199 ELSE FOR I
IN X
'RANGE LOOP
200 FOR J
IN X
'RANGE(2) LOOP
201 IF NOT EQUAL
(X
(I
, J
),
202 Y
(I
- X
'FIRST + Y
'FIRST,
215 FUNCTION EQUAL
(X
, Y
: ARRT
) RETURN BOOLEAN IS
217 IF X
'LENGTH /= Y
'LENGTH OR X
'LENGTH(2) /= Y
'LENGTH(2) THEN
219 ELSE FOR I
IN X
'RANGE LOOP
220 FOR J
IN X
'RANGE(2) LOOP
221 IF NOT EQUAL
(X
(I
, J
),
222 Y
(I
- X
'FIRST + Y
'FIRST,
234 TEST
("C34005S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
235 "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
236 "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
237 "TYPE IS A LIMITED TYPE. THIS TEST IS PART " &
238 "1 OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " &
239 "SECOND PART IS IN TEST C34005V");
241 ASSIGN
(X
(IDENT_INT
(4), IDENT_INT
(6)), CREATE
(1));
242 ASSIGN
(X
(IDENT_INT
(4), IDENT_INT
(7)), CREATE
(2));
243 ASSIGN
(X
(IDENT_INT
(4), IDENT_INT
(8)), CREATE
(3));
244 ASSIGN
(X
(IDENT_INT
(5), IDENT_INT
(6)), CREATE
(4));
245 ASSIGN
(X
(IDENT_INT
(5), IDENT_INT
(7)), CREATE
(5));
246 ASSIGN
(X
(IDENT_INT
(5), IDENT_INT
(8)), CREATE
(6));
248 ASSIGN
(W
(4, 6), CREATE
(1));
249 ASSIGN
(W
(4, 7), CREATE
(2));
250 ASSIGN
(W
(4, 8), CREATE
(3));
251 ASSIGN
(W
(5, 6), CREATE
(4));
252 ASSIGN
(W
(5, 7), CREATE
(5));
253 ASSIGN
(W
(5, 8), CREATE
(6));
255 ASSIGN
(C
, CREATE
(2));
257 ASSIGN
(U
(8, 2), CREATE
(1));
258 ASSIGN
(U
(8, 3), CREATE
(2));
259 ASSIGN
(U
(8, 4), CREATE
(3));
260 ASSIGN
(U
(9, 2), CREATE
(4));
261 ASSIGN
(U
(9, 3), CREATE
(5));
262 ASSIGN
(U
(9, 4), CREATE
(6));
264 IF NOT EQUAL
(X
(IDENT_INT
(4), IDENT_INT
(6)), C1
) OR
265 NOT EQUAL
(CREATE
(6, 9, 2, 3, C4
, X
) (9, 3), C11
) THEN
266 FAILED
("INCORRECT INDEX (VALUE)");
272 FAILED
("INCORRECT 'ADDRESS");
276 FAILED
("INCORRECT TYPE'FIRST");
280 FAILED
("INCORRECT OBJECT'FIRST");
284 FAILED
("INCORRECT VALUE'FIRST");
287 IF T
'FIRST (N
) /= 6 THEN
288 FAILED
("INCORRECT TYPE'FIRST (N)");
291 IF X
'FIRST (N
) /= 6 THEN
292 FAILED
("INCORRECT OBJECT'FIRST (N)");
295 IF V
'FIRST (N
) /= 6 THEN
296 FAILED
("INCORRECT VALUE'FIRST (N)");
300 FAILED
("INCORRECT TYPE'LAST");
304 FAILED
("INCORRECT OBJECT'LAST");
308 FAILED
("INCORRECT VALUE'LAST");
311 IF T
'LAST (N
) /= 8 THEN
312 FAILED
("INCORRECT TYPE'LAST (N)");
315 IF X
'LAST (N
) /= 8 THEN
316 FAILED
("INCORRECT OBJECT'LAST (N)");
319 IF V
'LAST (N
) /= 8 THEN
320 FAILED
("INCORRECT VALUE'LAST (N)");
323 IF T
'LENGTH /= 2 THEN
324 FAILED
("INCORRECT TYPE'LENGTH");
327 IF X
'LENGTH /= 2 THEN
328 FAILED
("INCORRECT OBJECT'LENGTH");
331 IF V
'LENGTH /= 2 THEN
332 FAILED
("INCORRECT VALUE'LENGTH");
335 IF T
'LENGTH (N
) /= 3 THEN
336 FAILED
("INCORRECT TYPE'LENGTH (N)");
339 IF X
'LENGTH (N
) /= 3 THEN
340 FAILED
("INCORRECT OBJECT'LENGTH (N)");
343 IF V
'LENGTH (N
) /= 3 THEN
344 FAILED
("INCORRECT VALUE'LENGTH (N)");
348 Y
: PARENT
(T
'RANGE, 1 .. 3);
350 IF Y
'FIRST /= 4 OR Y
'LAST /= 5 THEN
351 FAILED
("INCORRECT TYPE'RANGE");
356 Y
: PARENT
(X
'RANGE, 1 .. 3);
358 IF Y
'FIRST /= 4 OR Y
'LAST /= 5 THEN
359 FAILED
("INCORRECT OBJECT'RANGE");
364 Y
: PARENT
(V
'RANGE, 1 .. 3);
366 IF Y
'FIRST /= 4 OR Y
'LAST /= 5 THEN
367 FAILED
("INCORRECT VALUE'RANGE");
372 Y
: PARENT
(1 .. 2, T
'RANGE (N
));
374 IF Y
'FIRST (N
) /= 6 OR Y
'LAST (N
) /= 8 THEN
375 FAILED
("INCORRECT TYPE'RANGE (N)");
380 Y
: PARENT
(1 .. 2, X
'RANGE (N
));
382 IF Y
'FIRST (N
) /= 6 OR Y
'LAST (N
) /= 8 THEN
383 FAILED
("INCORRECT OBJECT'RANGE (N)");
388 Y
: PARENT
(1 .. 2, V
'RANGE (N
));
390 IF Y
'FIRST (N
) /= 6 OR Y
'LAST (N
) /= 8 THEN
391 FAILED
("INCORRECT VALUE'RANGE (N)");
395 IF T
'SIZE < T
'LENGTH * T
'LENGTH (N
) * COMPONENT
'SIZE THEN
396 FAILED
("INCORRECT TYPE'SIZE");
399 IF X
'SIZE < X
'LENGTH * X
'LENGTH (N
) * COMPONENT
'SIZE THEN
400 FAILED
("INCORRECT OBJECT'SIZE");