gcc/testsuite/ada/acats/tests/cc/cc1220a.ada

   1 -- CC1220A.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 --     CHECK THAT A GENERIC UNIT CAN REFER TO AN IMPLICITLY
  27 --     DECLARED PREDEFINED OPERATOR.
  28
  29 -- HISTORY:
  30 --     DAT 08/20/81  CREATED ORIGINAL TEST.
  31 --     SPS 05/03/82
  32 --     BCB 08/04/88  MODIFIED HEADER FORMAT AND ADDED CHECKS FOR OTHER
  33 --                   OPERATIONS OF A DISCRETE TYPE.
  34 --     RJW 03/27/90  REVISED TEST TO CHECK FOR A GENERIC FORMAL
  35 --                   DISCRETE TYPE.
  36 --     CJJ 10/14/90  ADDED CHECKS FOR RELATIONAL OPERATOR (<, <=, >, >=);
  37 --                   MADE FAILED MESSAGES IN PROCEDURE BODY MORE SPECIFIC.
  38
  39 WITH REPORT; USE REPORT;
  40 WITH SYSTEM; USE SYSTEM;
  41
  42 PROCEDURE CC1220A IS
  43
  44 BEGIN
  45      TEST ("CC1220A", "GENERIC UNIT CAN REFER TO IMPLICITLY " &
  46            "DECLARED OPERATORS");
  47
  48
  49      DECLARE
  50
  51           GENERIC
  52                TYPE T IS (<>);
  53                STR : STRING;
  54                P1 : T := T'FIRST;
  55                P2 : T := T(T'SUCC (P1));
  56                P3 : T := T'(T'PRED (P2));
  57                P4 : INTEGER := IDENT_INT(T'WIDTH);
  58                P5 : BOOLEAN := (P1 < P2) AND (P2 > P3);
  59                P6: BOOLEAN := (P1 <= P3) AND (P2 >= P1);
  60                P7 : BOOLEAN := (P3 = P1);
  61                P8 : T := T'BASE'FIRST;
  62                P10 : T := T'LAST;
  63                P11 : INTEGER := T'SIZE;
  64                P12 : ADDRESS := P10'ADDRESS;
  65                P13 : INTEGER := T'WIDTH;
  66                P14 : INTEGER := T'POS(T'LAST);
  67                P15 : T := T'VAL(1);
  68                P16 : INTEGER := T'POS(P15);
  69                P17 : STRING := T'IMAGE(T'BASE'LAST);
  70                P18 : T := T'VALUE(P17);
  71                P19 : BOOLEAN := (P15 IN T);
  72                WITH FUNCTION IDENT (X : T) RETURN T;
  73           PACKAGE PKG IS
  74                ARR : ARRAY (1 .. 3) OF T := (P1,P2,P3);
  75                B1 : BOOLEAN := P7 AND P19;
  76                B2 : BOOLEAN := P5 AND P6;
  77           END PKG;
  78
  79           PACKAGE BODY PKG IS
  80           BEGIN
  81                IF P1 /= T(T'FIRST) THEN
  82                     FAILED ("IMPROPER VALUE FOR 'FIRST - " & STR);
  83                END IF;
  84
  85                IF T'SUCC (P1) /= IDENT (P2) OR
  86                   T'PRED (P2) /= IDENT (P1) THEN
  87                     FAILED ("IMPROPER VALUE FOR 'SUCC, PRED - " & STR);
  88                END IF;
  89
  90                IF P10 /= T(T'LAST) THEN
  91                     FAILED ("IMPROPER VALUE FOR 'LAST - " & STR);
  92                END IF;
  93
  94                IF NOT EQUAL(P11,T'SIZE) THEN
  95                     FAILED ("IMPROPER VALUE FOR 'SIZE - " & STR);
  96                END IF;
  97
  98                IF NOT EQUAL(P13,T'WIDTH) THEN
  99                     FAILED ("IMPROPER VALUE FOR 'WIDTH - " & STR);
 100                END IF;
 101
 102                IF NOT EQUAL (P16, T'POS (P15)) OR
 103                   T'VAL (P16) /= T(IDENT (P15)) THEN
 104                     FAILED ("IMPROPER VALUE FOR 'POS, 'VAL - " & STR);
 105                END IF;
 106
 107                IF T'VALUE (P17) /= T'BASE'LAST OR
 108                   T'IMAGE (P18) /= T'IMAGE (T'BASE'LAST) THEN
 109                     FAILED ("IMPROPER VALUE FOR 'VALUE, 'IMAGE - " &
 110                              STR);
 111                END IF;
 112           END PKG;
 113
 114      BEGIN
 115           DECLARE
 116                TYPE CHAR IS ('A', 'B', 'C', 'D', 'E');
 117
 118                FUNCTION IDENT (C : CHAR) RETURN CHAR IS
 119                BEGIN
 120                     RETURN CHAR'VAL (IDENT_INT (CHAR'POS (C)));
 121                END IDENT;
 122
 123                PACKAGE N_CHAR IS NEW PKG (T => CHAR, STR => "CHAR",
 124                                           IDENT => IDENT);
 125           BEGIN
 126                IF N_CHAR.ARR (1) /= IDENT ('A') OR
 127                   N_CHAR.ARR (2) /= IDENT ('B') OR
 128                   N_CHAR.ARR (3) /= 'A' OR
 129                   N_CHAR.B1 /= TRUE OR
 130                  N_CHAR.B2 /= TRUE THEN
 131                     FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
 132                             " IN INSTANTIATION OF N_CHAR.");
 133                END IF;
 134           END;
 135
 136           DECLARE
 137                TYPE ENUM IS (JOVIAL, ADA, FORTRAN, BASIC);
 138
 139                FUNCTION IDENT (C : ENUM) RETURN ENUM IS
 140                BEGIN
 141                     RETURN ENUM'VAL (IDENT_INT (ENUM'POS (C)));
 142                END IDENT;
 143
 144                PACKAGE N_ENUM IS NEW PKG (T => ENUM, STR => "ENUM",
 145                                           IDENT => IDENT);
 146
 147           BEGIN
 148                IF N_ENUM.ARR (1) /= IDENT (JOVIAL) OR
 149                   N_ENUM.ARR (2) /= IDENT (ADA) OR
 150                   N_ENUM.ARR (3) /= JOVIAL OR
 151                   N_ENUM.B1 /= TRUE OR
 152                   N_ENUM.B2 /= TRUE THEN
 153                     FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
 154                             " IN INSTANTIATION OF N_ENUM.");
 155                END IF;
 156           END;
 157
 158           DECLARE
 159
 160                PACKAGE N_INT IS NEW PKG (T => INTEGER, STR => "INTEGER",
 161                                           IDENT => IDENT_INT);
 162           BEGIN
 163                IF N_INT.ARR (1) /= IDENT_INT (INTEGER'FIRST) OR
 164                   N_INT.ARR (2) /= IDENT_INT (INTEGER'FIRST + 1) OR
 165                   N_INT.ARR (3) /= INTEGER'FIRST OR
 166                   N_INT.B1 /= TRUE OR
 167                   N_INT.B2 /= TRUE THEN
 168                     FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" &
 169                             " IN INSTANTIATION OF N_INT.");
 170                END IF;
 171           END;
 172      END;
 173      RESULT;
 174 END CC1220A;