URL
https://opencores.org/ocsvn/scarts/scarts/trunk
Subversion Repositories scarts
[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c32107a.ada] - Rev 12
Compare with Previous | Blame | View Log
-- C32107A.ADA -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained -- unlimited rights in the software and documentation contained herein. -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making -- this public release, the Government intends to confer upon all -- recipients unlimited rights equal to those held by the Government. -- These rights include rights to use, duplicate, release or disclose the -- released technical data and computer software in whole or in part, in -- any manner and for any purpose whatsoever, and to have or permit others -- to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- CHECK THAT OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR -- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION -- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE -- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT -- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY -- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE -- EVALUATED. -- R.WILLIAMS 9/24/86 WITH REPORT; USE REPORT; PROCEDURE C32107A IS BUMP : INTEGER := 0; ORDER_CHECK : INTEGER; G1, H1, I1 : INTEGER; FIRST_CALL : BOOLEAN := TRUE; TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; TYPE ARR1_NAME IS ACCESS ARR1; TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF INTEGER; TYPE REC (D : INTEGER) IS RECORD COMP : INTEGER; END RECORD; TYPE REC_NAME IS ACCESS REC; FUNCTION F RETURN INTEGER IS BEGIN BUMP := BUMP + 1; RETURN BUMP; END F; FUNCTION G RETURN INTEGER IS BEGIN BUMP := BUMP + 1; G1 := BUMP; RETURN BUMP; END G; FUNCTION H RETURN INTEGER IS BEGIN BUMP := BUMP + 1; H1 := BUMP; RETURN BUMP; END H; FUNCTION I RETURN INTEGER IS BEGIN IF FIRST_CALL THEN BUMP := BUMP + 1; I1 := BUMP; FIRST_CALL := FALSE; END IF; RETURN I1; END I; BEGIN TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " & "ELABORATED IN THE ORDER OF THEIR " & "OCCURRENCE, I.E., THAT EXPRESSIONS " & "ASSOCIATED WITH ONE DECLARATION (INCLUDING " & "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " & "EVALUATED BEFORE ANY EXPRESSION BELONGING " & "TO THE NEXT DECLARATION. ALSO, CHECK THAT " & "EXPRESSIONS IN THE SUBTYPE INDICATION OR " & "THE CONSTRAINED ARRAY DEFINITION ARE " & "EVALUATED BEFORE ANY INITIALIZATION " & "EXPRESSIONS ARE EVALUATED" ); DECLARE -- (A). I1 : INTEGER := 10000 * F; A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) := (1 .. H1 => (G1 * 100, I * 10)); I2 : CONSTANT INTEGER := F * 1000; BEGIN ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP; IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " & "15242 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); END IF; END; -- (A). BUMP := 0; DECLARE -- (B). A : ARR2 (1 .. F, 1 .. F * 10); R : REC (G * 100) := (G1 * 100, F * 1000); I : INTEGER RANGE 1 .. H; S : REC (F * 10); BEGIN ORDER_CHECK := A'LAST (1) + A'LAST (2) + R.D + R.COMP; IF (H1 + S.D = 65) AND (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN COMMENT ( "ORDER_CHECK HAS VALUE 65 " & INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " & "65 4312 -- ACTUAL VALUE IS " & INTEGER'IMAGE (H1 + S.D) & INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); END IF; END; -- (B). BUMP := 0; DECLARE -- (C). I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F; A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000; BEGIN ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000); IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " & "3412 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); END IF; END; -- (C). BUMP := 0; FIRST_CALL := TRUE; DECLARE -- (D). A1 : ARRAY (1 .. G) OF REC (H * 10000) := (1 .. G1 => (H1 * 10000, I * 100)); R1 : CONSTANT REC := (F * 1000, F * 10); BEGIN ORDER_CHECK := A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP; IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 25341, " & "24351, 15342 OR 14352 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); END IF; END; -- (D). BUMP := 0; DECLARE -- (E). A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10); R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000); BEGIN ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP; IF ORDER_CHECK /= 4321 THEN FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4321 " & "-- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (E)" ); END IF; END; -- (E). BUMP := 0; FIRST_CALL := TRUE; DECLARE -- (F). A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 := (1 .. G1 => I * 10); A2 : ARR1 (1 .. F * 1000); BEGIN ORDER_CHECK := A1'LAST + (H1 * 100) + A1 (1) + A2'LAST; IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " & "4132 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); END IF; END; -- (F). BUMP := 0; DECLARE -- (G). A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1); R1 : CONSTANT REC_NAME (H * 10) := NEW REC'(H1 * 10, F * 100); BEGIN ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP; IF ORDER_CHECK /= 321 THEN FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 321 OR " & "-- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (G)" ); END IF; END; -- (G). BUMP := 0; DECLARE -- (H). TYPE REC (D : INTEGER := F) IS RECORD COMP : INTEGER := F * 10; END RECORD; R1 : REC; R2 : REC (G * 100) := (G1 * 100, F * 1000); BEGIN ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP; IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4321, " & "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); END IF; END; -- (H). BUMP := 0; DECLARE -- (I). TYPE REC2 (D1, D2 : INTEGER) IS RECORD COMP : INTEGER; END RECORD; R1 : REC2 (G * 1000, H * 10000) := (G1 * 1000, H1 * 10000, F * 100); R2 : REC2 (F, F * 10); BEGIN ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2; IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 21354, " & "21345, 12354, OR 12345 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); END IF; END; -- (I). BUMP := 0; DECLARE -- (J). PACKAGE P IS TYPE PRIV (D : INTEGER) IS PRIVATE; P1 : CONSTANT PRIV; P2 : CONSTANT PRIV; FUNCTION GET_A (P : PRIV) RETURN INTEGER; PRIVATE TYPE PRIV (D : INTEGER) IS RECORD COMP : INTEGER; END RECORD; P1 : CONSTANT PRIV := (F , F * 10); P2 : CONSTANT PRIV := (F * 100, F * 1000); END P; PACKAGE BODY P IS FUNCTION GET_A (P : PRIV) RETURN INTEGER IS BEGIN RETURN P.COMP; END GET_A; END P; USE P; BEGIN ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2); IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4321, " & "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); END IF; END; -- (J). BUMP := 0; DECLARE -- (K). PACKAGE P IS TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE; PRIVATE TYPE PRIV (D1, D2 : INTEGER) IS RECORD NULL; END RECORD; END P; USE P; P1 : PRIV (F, F * 10); P2 : PRIV (F * 100, F * 1000); BEGIN ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2; IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN COMMENT ( "ORDER_CHECK HAS VALUE " & INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); ELSE FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " & "3421, OR 3412 -- ACTUAL VALUE IS " & INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); END IF; END; -- (K). RESULT; END C32107A;