diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c46014a.ada')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c46014a.ada | 287 |
1 files changed, 287 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c46014a.ada b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c46014a.ada new file mode 100644 index 000000000..9f47479df --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c4/c46014a.ada @@ -0,0 +1,287 @@ +-- C46014A.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: +-- FOR PREDEFINED TYPE INTEGER, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF THE OPERAND VALUE OF A +-- CONVERSION LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S BASE +-- TYPE. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE +-- OPERAND VALUE LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S +-- SUBTYPE BUT WITHIN THE RANGE OF THE BASE TYPE. + +-- HISTORY: +-- RJW 09/08/86 CREATED ORIGINAL TEST. +-- RJW 11/13/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. +-- JET 12/30/87 ADDED MORE CODE TO PREVENT OPTIMIZATION. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY +-- JRL 12/08/96 Changed usages of System.Max_Int and System.Min_Int to +-- Integer'Base'Last and Integer'Base'First in first two +-- subtests. + +WITH REPORT; USE REPORT; +PROCEDURE C46014A IS + + SUBTYPE SMALL IS INTEGER RANGE -100 .. 100; + S1 : SMALL; + + TYPE INT IS RANGE -100 .. 100; + T1 : INT; + + TYPE NEWINTEGER IS NEW INTEGER; + N1 : NEWINTEGER; + + SUBTYPE SUBNEW IS NEWINTEGER RANGE -100 .. 100; + SN : SUBNEW; + + I1 : INTEGER; + P1 : POSITIVE; + L1 : NATURAL; + + FUNCTION IDENT (I : INTEGER) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (I)); + END IDENT; + + FUNCTION IDENT (I : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (I))); + END IDENT; + +BEGIN + TEST ( "C46014A", "FOR PREDEFINED TYPE INTEGER, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF " & + "THE OPERAND VALUE OF A CONVERSION LIES " & + "OUTSIDE OF THE RANGE OF THE TARGET TYPE'S " & + "BASE TYPE. ALSO, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF THE OPERAND " & + "VALUE LIES OUTSIDE OF THE RANGE OF THE " & + "TARGET TYPE'S SUBTYPE BUT WITHIN THE " & + "RANGE OF THE BASE TYPE" ); + + BEGIN + I1 := Integer'Base'Last + Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'LAST + 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + END; + + BEGIN + I1 := Integer'Base'First - Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'FIRST - 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + END; + + BEGIN + I1 := INTEGER (IDENT_INT (INTEGER'FIRST) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST) - 1)" ); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + END; + + BEGIN + N1 := NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1)" ); + IF EQUAL (INTEGER (N1), INTEGER (N1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + END; + + BEGIN + T1 := INT (INT'BASE'FIRST - IDENT (1)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + END; + + BEGIN + T1 := IDENT (-101); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := -101" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := -101" ); + END; + + BEGIN + T1 := INTEGER'POS (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101));" ); + END; + + BEGIN + T1 := INT (IDENT (INTEGER (INT'FIRST)) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + END; + + BEGIN + T1 := INT (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR INT (101)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INT (101)" ); + END; + + BEGIN + S1 := SMALL (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR SMALL (101)" ); + IF EQUAL (S1, S1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SMALL (101)" ); + END; + + BEGIN + SN := SUBNEW (IDENT_INT (-101)); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (-101)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (-101)" ); + END; + + BEGIN + P1 := IDENT_INT (101); + SN := SUBNEW (P1); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (P1)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (P1)" ); + END; + + BEGIN + SN := IDENT (0); + P1 := POSITIVE (SN); + FAILED ( "NO EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + IF EQUAL (P1, P1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + END; + + BEGIN + N1 := IDENT (-1); + L1 := NATURAL (N1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + IF EQUAL (L1, L1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + END; + + RESULT; +END C46014A; |