diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc1221c.ada')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc1221c.ada | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada new file mode 100644 index 000000000..21738858e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada @@ -0,0 +1,195 @@ +-- CC1221C.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 A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC +-- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE +-- WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC, +-- 'IMAGE, AND 'VALUE. + +-- HISTORY: +-- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE CC1221C IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + TYPE INT1 IS RANGE -6 .. 6; + +BEGIN + TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " & + "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE"); + + DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART III. + + GENERIC + TYPE T IS RANGE <>; + F : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + I : INTEGER; + Y : T; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'SUCC (T'FIRST); + END IF; + END IDENT; + + BEGIN + I := F; + FOR X IN T LOOP + IF T'VAL (I) /= X THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'VAL OF " & INTEGER'IMAGE (I)); + END IF; + + IF T'POS (X) /= I THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'POS OF " & T'IMAGE (X)); + END IF; + + I := I + 1; + END LOOP; + + FOR X IN T LOOP + IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'SUCC OF " & T'IMAGE (X)); + END IF; + + IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'PRED OF " & T'IMAGE (X)); + END IF; + END LOOP; + + BEGIN + Y := T'SUCC (IDENT (T'BASE'LAST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + END; + + BEGIN + Y := T'PRED (IDENT (T'BASE'FIRST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + END; + + END P; + + PROCEDURE P1 IS NEW P (SUBINT, -100); + PROCEDURE P2 IS NEW P (SINT1, -4); + PROCEDURE P3 IS NEW P (INT1, -6); + + BEGIN + P1 ( "SUBINT" ); + P2 ( "SINT" ); + P3 ( "INT1" ); + END; -- (C1). + + DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART IV. + + GENERIC + TYPE T IS RANGE <>; + STR : STRING; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + PROCEDURE P (IM : STRING; VA : T) IS + BEGIN + IF T'IMAGE (VA) /= IM THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'IMAGE OF " & + INTEGER'IMAGE (INTEGER (VA))); + END IF; + END P; + + PROCEDURE Q (IM : STRING; VA : T) IS + BEGIN + IF T'VALUE (IM) /= VA THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'VALUE OF " & IM); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + STR &"'VALUE OF " & IM); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + STR &"'VALUE OF " & IM); + + END Q; + + BEGIN + P (" 2", 2); + P ("-1", -1); + + Q (" 2", 2); + Q ("-1", -1); + Q (" 2", 2); + Q ("-1 ", -1); + END PKG; + + PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT"); + PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1"); + PACKAGE PKG3 IS NEW PKG (INT1, "INT1"); + PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT"); + + BEGIN + NULL; + END; -- (C2). + + RESULT; +END CC1221C; |