diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c4/c43004a.ada')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c4/c43004a.ada | 350 |
1 files changed, 350 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c4/c43004a.ada b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada new file mode 100644 index 000000000..86e705de7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada @@ -0,0 +1,350 @@ +-- C43004A.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. +--* +-- OBJECTIVE: +-- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A VALUE FOR A +-- NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT +-- WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE. + +-- HISTORY: +-- BCB 01/22/88 CREATED ORIGINAL TEST. +-- RJW 06/27/90 CORRECTED CONSTRAINTS OF TYPE DFIX. +-- LDC 09/25/90 ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN +-- NOT OPTIMIZE IT AWAY, ALSO INITIALIZED EACH +-- OBJECT TO VALID DATA BEFORE DOING THE INVALID, +-- MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN +-- NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE +-- FOR A CONSTRAINT ERROR IN IS PLACE. +-- JRL 06/07/96 Changed value in aggregate in subtest 4 to value +-- guaranteed to be in the base range of the type FIX. +-- Corrected typo. + +WITH REPORT; USE REPORT; + +PROCEDURE C43004A IS + + TYPE INT IS RANGE 1 .. 8; + SUBTYPE SINT IS INT RANGE 2 .. 7; + + TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE); + SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN; + + TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0; + SUBTYPE SFL IS FL RANGE 1.0 .. 9.0; + + TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0; + SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0; + + TYPE DINT IS NEW INTEGER RANGE 1 .. 8; + SUBTYPE SDINT IS DINT RANGE 2 .. 7; + + TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE; + SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN; + + TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0; + SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0; + + TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5; + SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0; + + TYPE REC1 IS RECORD + E1, E2, E3, E4, E5 : SENUM; + END RECORD; + + TYPE REC2 IS RECORD + E1, E2, E3, E4, E5 : SFIX; + END RECORD; + + TYPE REC3 IS RECORD + E1, E2, E3, E4, E5 : SDENUM; + END RECORD; + + TYPE REC4 IS RECORD + E1, E2, E3, E4, E5 : SDFIX; + END RECORD; + + ARRAY_OBJ : ARRAY(1..2) OF INTEGER; + + A : ARRAY(1..5) OF SINT; + B : REC1; + C : ARRAY(1..5) OF SFL; + D : REC2; + E : ARRAY(1..5) OF SDINT; + F : REC3; + G : ARRAY(1..5) OF SDFL; + H : REC4; + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN; + + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END GENEQUAL; + + FUNCTION EQUAL IS NEW GENEQUAL(SENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SFL); + FUNCTION EQUAL IS NEW GENEQUAL(SFIX); + FUNCTION EQUAL IS NEW GENEQUAL(SDENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SDFL); + FUNCTION EQUAL IS NEW GENEQUAL(SDFIX); + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE) + RETURN BOOLEAN; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS + BEGIN + IF EQUAL_GENERAL (X, X) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + -- NEVER EXECUTED. + RETURN X; + END GEN_IDENT; + + FUNCTION IDENT_FL IS NEW GEN_IDENT(FL, EQUAL); + FUNCTION IDENT_FIX IS NEW GEN_IDENT(FIX, EQUAL); + FUNCTION IDENT_DFL IS NEW GEN_IDENT(DFL, EQUAL); + FUNCTION IDENT_DFIX IS NEW GEN_IDENT(DFIX, EQUAL); + +BEGIN + TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & + "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " & + "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " & + "THE COMPONENT'S SUBTYPE"); + + ARRAY_OBJ := (1, 2); + + BEGIN + A := (2,3,4,5,6); -- OK + + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + + A := (SINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 1"); + END; + + BEGIN + B := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + + IF EQUAL (B.E1, B.E2) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + + B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF AN + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); + IF NOT EQUAL (B.E1, B.E1) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 2"); + END; + BEGIN + C := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + + C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FLOATING POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); + IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 3"); + END; + + BEGIN + D := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (D.E1, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + + D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FIXED POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); + IF NOT EQUAL (D.E5, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 4"); + END; + + BEGIN + E := (2,3,4,5,6); -- OK + IF EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + + E := (SDINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5"); + IF NOT EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 5"); + END; + + BEGIN + F := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + IF EQUAL (F.E1, F.E2) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + + F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF A DERIVED + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6"); + IF NOT EQUAL (F.E1, F.E1) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 6"); + END; + + BEGIN + G := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + + G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FLOATING POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); + IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 7"); + END; + + BEGIN + H := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (H.E1, H.E2) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + + H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FIXED POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); + IF EQUAL (H.E1, H.E5) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 8"); + END; + + + RESULT; +END C43004A; |