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 ONE-DIMENSIONAL ARRAY TYPES WHOSE
28 -- COMPONENT TYPE IS A LIMITED TYPE.
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
40 WITH SYSTEM
; USE SYSTEM
;
41 WITH REPORT
; USE REPORT
;
47 TYPE LP
IS LIMITED PRIVATE;
49 FUNCTION CREATE
(X
: INTEGER) RETURN LP
;
51 FUNCTION VALUE
(X
: LP
) RETURN INTEGER;
53 FUNCTION EQUAL
(X
, Y
: LP
) RETURN BOOLEAN;
55 PROCEDURE ASSIGN
(X
: OUT LP
; Y
: LP
);
66 TYPE LP
IS NEW INTEGER;
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;
79 SUBTYPE COMPONENT
IS LP
;
83 FIRST
: CONSTANT := 0;
84 LAST
: CONSTANT := 100;
86 SUBTYPE INDEX
IS INTEGER RANGE FIRST
.. LAST
;
88 TYPE PARENT
IS ARRAY (INDEX
RANGE <>) OF COMPONENT
;
90 FUNCTION CREATE
( F
, L
: INDEX
;
92 DUMMY
: PARENT
-- TO RESOLVE OVERLOADING.
95 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN;
97 FUNCTION AGGR
(X
, Y
: COMPONENT
) RETURN PARENT
;
99 FUNCTION AGGR
(X
, Y
, Z
: COMPONENT
) RETURN PARENT
;
105 TYPE T
IS NEW PARENT
(IDENT_INT
(5) .. IDENT_INT
(7));
110 B
: BOOLEAN := FALSE;
113 PROCEDURE A
(X
: ADDRESS
) IS
115 B
:= IDENT_BOOL
(TRUE);
118 FUNCTION V
RETURN T
IS
121 FOR I
IN RESULT
'RANGE LOOP
122 ASSIGN
(RESULT
(I
), C
);
127 PACKAGE BODY PKG_L
IS
129 FUNCTION CREATE
(X
: INTEGER) RETURN LP
IS
131 RETURN LP
(IDENT_INT
(X
));
134 FUNCTION VALUE
(X
: LP
) RETURN INTEGER IS
139 FUNCTION EQUAL
(X
, Y
: LP
) RETURN BOOLEAN IS
144 PROCEDURE ASSIGN
(X
: OUT LP
; Y
: LP
) IS
151 PACKAGE BODY PKG_P
IS
165 ASSIGN
(B
, CREATE
(VALUE
(B
) + 1));
170 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN IS
172 IF X
'LENGTH /= Y
'LENGTH THEN
174 ELSE FOR I
IN X
'RANGE LOOP
176 Y
(I
- X
'FIRST + Y
'FIRST)) THEN
184 FUNCTION AGGR
(X
, Y
: COMPONENT
) RETURN PARENT
IS
185 RESULT
: PARENT
(INDEX
'FIRST .. INDEX
'FIRST + 1);
187 ASSIGN
(RESULT
(INDEX
'FIRST ), X
);
188 ASSIGN
(RESULT
(INDEX
'FIRST + 1), Y
);
192 FUNCTION AGGR
(X
, Y
, Z
: COMPONENT
) RETURN PARENT
IS
193 RESULT
: PARENT
(INDEX
'FIRST .. INDEX
'FIRST + 2);
195 ASSIGN
(RESULT
(INDEX
'FIRST ), X
);
196 ASSIGN
(RESULT
(INDEX
'FIRST + 1), Y
);
197 ASSIGN
(RESULT
(INDEX
'FIRST + 2), Z
);
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");
209 ASSIGN
(X
(IDENT_INT
(5)), CREATE
(1));
210 ASSIGN
(X
(IDENT_INT
(6)), CREATE
(2));
211 ASSIGN
(X
(IDENT_INT
(7)), CREATE
(3));
213 ASSIGN
(W
(5), CREATE
(1));
214 ASSIGN
(W
(6), CREATE
(2));
215 ASSIGN
(W
(7), CREATE
(3));
217 ASSIGN
(C
, CREATE
(2));
219 IF NOT EQUAL
(T
'(X), AGGR (C1, C2, C3)) THEN
220 FAILED ("INCORRECT QUALIFICATION");
223 IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN
224 FAILED ("INCORRECT SELF CONVERSION");
227 IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN
228 FAILED ("INCORRECT CONVERSION FROM PARENT");
231 IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN
232 FAILED ("INCORRECT CONVERSION TO PARENT - 1");
236 IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)),
238 FAILED ("INCORRECT CONVERSION TO PARENT - 2");
242 FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " &
243 "VALUES OUTSIDE OF THE SUBTYPE T - 1");
246 IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN
247 FAILED ("INCORRECT INDEX (VALUE)");
251 IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)),
253 NOT EQUAL (CREATE (1, 4, C4, X)(1..3),
254 AGGR (C4, C5, C6)) THEN
255 FAILED ("INCORRECT SLICE (VALUE)");
259 FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES");
262 IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN
263 FAILED ("INCORRECT ""IN""");
266 IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN
267 FAILED ("INCORRECT ""NOT IN""");
273 FAILED ("INCORRECT 'ADDRESS
");
277 FAILED ("INCORRECT
TYPE'FIRST");
281 FAILED ("INCORRECT OBJECT
'FIRST");
285 FAILED ("INCORRECT VALUE
'FIRST");
288 IF T'FIRST (N) /= 5 THEN
289 FAILED ("INCORRECT
TYPE'FIRST (N
)");
292 IF X'FIRST (N) /= 5 THEN
293 FAILED ("INCORRECT OBJECT
'FIRST (N
)");
296 IF V'FIRST (N) /= 5 THEN
297 FAILED ("INCORRECT VALUE
'FIRST (N
)");
301 FAILED ("INCORRECT
TYPE'LAST");
305 FAILED ("INCORRECT OBJECT
'LAST");
309 FAILED ("INCORRECT VALUE
'LAST");
312 IF T'LAST (N) /= 7 THEN
313 FAILED ("INCORRECT
TYPE'LAST (N
)");
316 IF X'LAST (N) /= 7 THEN
317 FAILED ("INCORRECT OBJECT
'LAST (N
)");
320 IF V'LAST (N) /= 7 THEN
321 FAILED ("INCORRECT VALUE
'LAST (N
)");
324 IF T'LENGTH /= 3 THEN
325 FAILED ("INCORRECT
TYPE'LENGTH");
328 IF X'LENGTH /= 3 THEN
329 FAILED ("INCORRECT OBJECT
'LENGTH");
332 IF V'LENGTH /= 3 THEN
333 FAILED ("INCORRECT VALUE
'LENGTH");
336 IF T'LENGTH (N) /= 3 THEN
337 FAILED ("INCORRECT
TYPE'LENGTH (N
)");
340 IF X'LENGTH (N) /= 3 THEN
341 FAILED ("INCORRECT OBJECT
'LENGTH (N
)");
344 IF V'LENGTH (N) /= 3 THEN
345 FAILED ("INCORRECT VALUE
'LENGTH (N
)");
349 Y : PARENT (T'RANGE);
351 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
352 FAILED ("INCORRECT
TYPE'RANGE");
357 Y : PARENT (X'RANGE);
359 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
360 FAILED ("INCORRECT OBJECT
'RANGE");
365 Y : PARENT (V'RANGE);
367 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
368 FAILED ("INCORRECT VALUE
'RANGE");
373 Y : PARENT (T'RANGE (N));
375 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
376 FAILED ("INCORRECT
TYPE'RANGE (N
)");
381 Y : PARENT (X'RANGE (N));
383 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
384 FAILED ("INCORRECT OBJECT
'RANGE (N
)");
389 Y : PARENT (V'RANGE (N));
391 IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
392 FAILED ("INCORRECT VALUE
'RANGE (N
)");
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");
401 COMMENT ("X
'SIZE > T
'SIZE");