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 -- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS
29 -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT
30 -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION
33 -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS
34 -- ALSO IMPOSED ON THE DERIVED SUBTYPE.
37 -- JRK 08/21/87 CREATED ORIGINAL TEST.
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
);
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;
74 C7
: CONSTANT LP
:= 7;
75 C8
: CONSTANT LP
:= 8;
81 SUBTYPE COMPONENT
IS LP
;
85 FIRST
: CONSTANT := 0;
86 LAST
: CONSTANT := 10;
88 SUBTYPE INDEX
IS INTEGER RANGE FIRST
.. LAST
;
90 TYPE PARENT
IS ARRAY (INDEX
RANGE <>, INDEX
RANGE <>) OF
93 FUNCTION CREATE
( F1
, L1
: INDEX
;
96 DUMMY
: PARENT
-- TO RESOLVE OVERLOADING.
99 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN;
101 FUNCTION AGGR
(A
, B
, C
, D
, E
, F
, G
, H
: COMPONENT
)
108 TYPE T
IS NEW PARENT
(IDENT_INT
(4) .. IDENT_INT
(5),
109 IDENT_INT
(6) .. IDENT_INT
(8));
111 SUBTYPE SUBPARENT
IS PARENT
(4 .. 5, 6 .. 8);
113 TYPE S
IS NEW SUBPARENT
;
118 PACKAGE BODY PKG_L
IS
120 FUNCTION CREATE
(X
: INTEGER) RETURN LP
IS
122 RETURN LP
(IDENT_INT
(X
));
125 FUNCTION VALUE
(X
: LP
) RETURN INTEGER IS
130 FUNCTION EQUAL
(X
, Y
: LP
) RETURN BOOLEAN IS
135 PROCEDURE ASSIGN
(X
: OUT LP
; Y
: LP
) IS
142 PACKAGE BODY PKG_P
IS
151 A
: PARENT
(F1
.. L1
, F2
.. L2
);
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));
164 FUNCTION EQUAL
(X
, Y
: PARENT
) RETURN BOOLEAN IS
166 IF X
'LENGTH /= Y
'LENGTH OR
167 X
'LENGTH(2) /= Y
'LENGTH(2) THEN
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,
183 FUNCTION AGGR
(A
, B
, C
, D
, E
, F
, G
, H
: COMPONENT
)
185 X
: PARENT
(INDEX
'FIRST .. INDEX
'FIRST + 3,
186 INDEX
'FIRST .. INDEX
'FIRST + 1);
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
);
201 PROCEDURE ASSIGN
(X
: IN OUT T
; Y
: T
) IS
203 FOR I
IN X
'RANGE LOOP
204 FOR J
IN X
'RANGE(2) LOOP
205 ASSIGN
(X
(I
, J
), Y
(I
, J
));
210 PROCEDURE ASSIGN
(X
: IN OUT S
; Y
: S
) IS
212 FOR I
IN X
'RANGE LOOP
213 FOR J
IN X
'RANGE(2) LOOP
214 ASSIGN
(X
(I
, J
), Y
(I
, J
));
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");
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
);
236 -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
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 " &
246 WHEN CONSTRAINT_ERROR
=>
247 FAILED
("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " &
248 "TYPE VALUES OUTSIDE THE SUBTYPE");
250 FAILED
("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " &
251 "VALUES OUTSIDE THE SUBTYPE");
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""");
259 -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
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");
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");
276 FAILED
("EXCEPTION RAISED BY OK ASSIGN CALL");
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))");
288 WHEN CONSTRAINT_ERROR
=>
291 FAILED
("WRONG EXCEPTION RAISED -- " &
292 "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))");
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))");
304 WHEN CONSTRAINT_ERROR
=>
307 FAILED
("WRONG EXCEPTION RAISED -- " &
308 "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))");
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))");
320 WHEN CONSTRAINT_ERROR
=>
323 FAILED
("WRONG EXCEPTION RAISED -- " &
324 "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))");
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))");
336 WHEN CONSTRAINT_ERROR
=>
339 FAILED
("WRONG EXCEPTION RAISED -- " &
340 "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))");
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))");
352 WHEN CONSTRAINT_ERROR
=>
355 FAILED
("WRONG EXCEPTION RAISED -- " &
356 "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))");
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))");
368 WHEN CONSTRAINT_ERROR
=>
371 FAILED
("WRONG EXCEPTION RAISED -- " &
372 "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))");
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))");
384 WHEN CONSTRAINT_ERROR
=>
387 FAILED
("WRONG EXCEPTION RAISED -- " &
388 "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))");
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))");
400 WHEN CONSTRAINT_ERROR
=>
403 FAILED
("WRONG EXCEPTION RAISED -- " &
404 "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))");