diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada | 363 |
1 files changed, 363 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada new file mode 100644 index 000000000..fd4ed0926 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c32107a.ada @@ -0,0 +1,363 @@ +-- 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; |