cc1221c.ada

来自「linux下编程用 编译软件」· ADA 代码 · 共 196 行

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