-- 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;