gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada

   1 -- CC1221C.ADA
   2
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 -- OBJECTIVE:
  26 --     FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC
  27 --     OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE
  28 --     WITHIN THE GENERIC UNIT:  ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC,
  29 --     'IMAGE, AND 'VALUE.
  30
  31 -- HISTORY:
  32 --     BCB 11/12/87  CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA
  33
  34 WITH SYSTEM; USE SYSTEM;
  35 WITH REPORT; USE REPORT;
  36 PROCEDURE CC1221C IS
  37
  38      SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100;
  39      TYPE NEWINT IS NEW INTEGER;
  40      TYPE INT IS RANGE -300 .. 300;
  41      SUBTYPE SINT1 IS INT
  42           RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4));
  43      TYPE INT1 IS RANGE -6 .. 6;
  44
  45 BEGIN
  46      TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " &
  47                        "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " &
  48                        "DECLARED AND ARE THEREFORE AVAILABLE " &
  49                        "WITHIN THE GENERIC UNIT:  ATTRIBUTES 'POS, " &
  50                        "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE");
  51
  52      DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
  53              --      PART III.
  54
  55           GENERIC
  56                TYPE T IS RANGE <>;
  57                F : INTEGER;
  58           PROCEDURE P (STR : STRING);
  59
  60           PROCEDURE P (STR : STRING) IS
  61                I : INTEGER;
  62                Y : T;
  63
  64                FUNCTION IDENT (X : T) RETURN T IS
  65                BEGIN
  66                     IF EQUAL (3, 3) THEN
  67                          RETURN X;
  68                     ELSE
  69                          RETURN T'SUCC (T'FIRST);
  70                     END IF;
  71                END IDENT;
  72
  73           BEGIN
  74                I := F;
  75                FOR X IN T LOOP
  76                     IF T'VAL (I) /= X THEN
  77                          FAILED ( "WRONG VALUE FOR " & STR &
  78                                   "'VAL OF " & INTEGER'IMAGE (I));
  79                     END IF;
  80
  81                     IF T'POS (X) /= I THEN
  82                          FAILED ( "WRONG VALUE FOR " & STR &
  83                                   "'POS OF " & T'IMAGE (X));
  84                     END IF;
  85
  86                     I := I + 1;
  87                END LOOP;
  88
  89                FOR X IN T LOOP
  90                     IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN
  91                          FAILED ( "WRONG VALUE FOR " & STR &
  92                                   "'SUCC OF " & T'IMAGE (X));
  93                     END IF;
  94
  95                     IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN
  96                          FAILED ( "WRONG VALUE FOR " & STR &
  97                                   "'PRED OF " & T'IMAGE (X));
  98                     END IF;
  99                END LOOP;
 100
 101                BEGIN
 102                     Y := T'SUCC (IDENT (T'BASE'LAST));
 103                     FAILED ( "NO EXCEPTION RAISED FOR " &
 104                               STR & "'SUCC (IDENT (" & STR &
 105                              "'BASE'LAST))" );
 106                EXCEPTION
 107                     WHEN CONSTRAINT_ERROR =>
 108                          NULL;
 109                     WHEN OTHERS =>
 110                          FAILED ( "WRONG EXCEPTION RAISED FOR " &
 111                                    STR & "'SUCC (IDENT (" & STR &
 112                                   "'BASE'LAST))" );
 113                END;
 114
 115                BEGIN
 116                     Y := T'PRED (IDENT (T'BASE'FIRST));
 117                     FAILED ( "NO EXCEPTION RAISED FOR " &
 118                               STR & "'PRED (IDENT (" & STR &
 119                              "'BASE'FIRST))" );
 120                EXCEPTION
 121                     WHEN CONSTRAINT_ERROR =>
 122                          NULL;
 123                     WHEN OTHERS =>
 124                          FAILED ( "WRONG EXCEPTION RAISED FOR " &
 125                                    STR & "'PRED (IDENT (" & STR &
 126                                   "'BASE'FIRST))" );
 127                END;
 128
 129           END P;
 130
 131           PROCEDURE P1 IS NEW P (SUBINT, -100);
 132           PROCEDURE P2 IS NEW P (SINT1, -4);
 133           PROCEDURE P3 IS NEW P (INT1, -6);
 134
 135      BEGIN
 136            P1 ( "SUBINT" );
 137            P2 ( "SINT" );
 138            P3 ( "INT1" );
 139      END; -- (C1).
 140
 141      DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE.
 142              --      PART IV.
 143
 144           GENERIC
 145                TYPE T IS RANGE <>;
 146                STR : STRING;
 147           PACKAGE PKG IS END PKG;
 148
 149           PACKAGE BODY PKG IS
 150                PROCEDURE P (IM : STRING; VA : T) IS
 151                BEGIN
 152                     IF T'IMAGE (VA) /= IM THEN
 153                          FAILED ( "INCORRECT RESULTS FOR " & STR &
 154                                   "'IMAGE OF " &
 155                                    INTEGER'IMAGE (INTEGER (VA)));
 156                     END IF;
 157                END P;
 158
 159                PROCEDURE Q (IM : STRING; VA : T) IS
 160                BEGIN
 161                     IF T'VALUE (IM) /= VA THEN
 162                          FAILED ( "INCORRECT RESULTS FOR " & STR &
 163                                   "'VALUE OF " & IM);
 164                     END IF;
 165                EXCEPTION
 166                     WHEN CONSTRAINT_ERROR =>
 167                          FAILED ( "CONSTRAINT_ERROR RAISED FOR " &
 168                                    STR &"'VALUE OF " & IM);
 169                     WHEN OTHERS =>
 170                          FAILED ( "OTHER EXCEPTION RAISED FOR " &
 171                                    STR &"'VALUE OF " & IM);
 172
 173                END Q;
 174
 175           BEGIN
 176                P (" 2", 2);
 177                P ("-1", -1);
 178
 179                Q (" 2", 2);
 180                Q ("-1", -1);
 181                Q ("        2", 2);
 182                Q ("-1     ", -1);
 183           END PKG;
 184
 185           PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT");
 186           PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1");
 187           PACKAGE PKG3 IS NEW PKG (INT1, "INT1");
 188           PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT");
 189
 190      BEGIN
 191           NULL;
 192      END; -- (C2).
 193
 194      RESULT;
 195 END CC1221C;