URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc1221c.ada] - Rev 816
Compare with Previous | Blame | View Log
-- 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;