gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c34005v.ada

   1 -- C34005V.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
  27 --     (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE
  28 --     COMPONENT TYPE IS A LIMITED TYPE.  THIS TEST IS PART 2 OF 2
  29 --     TESTS WHICH COVER THE OBJECTIVE.  THE FIRST PART IS IN TEST
  30 --     C34005S.
  31
  32 -- HISTORY:
  33 --     BCB 04/12/90  CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA.
  34 --     RLB 10/03/02  REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND
  35 --                   SUPPORTING CODE.
  36
  37 WITH SYSTEM; USE SYSTEM;
  38 WITH REPORT; USE REPORT;
  39
  40 PROCEDURE C34005V IS
  41
  42      PACKAGE PKG_L IS
  43
  44           TYPE LP IS LIMITED PRIVATE;
  45
  46           FUNCTION CREATE (X : INTEGER) RETURN LP;
  47
  48           FUNCTION VALUE (X : LP) RETURN INTEGER;
  49
  50           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN;
  51
  52           PROCEDURE ASSIGN (X : OUT LP; Y : LP);
  53
  54           C1  : CONSTANT LP;
  55           C2  : CONSTANT LP;
  56           C3  : CONSTANT LP;
  57           C4  : CONSTANT LP;
  58           C5  : CONSTANT LP;
  59           C6  : CONSTANT LP;
  60           C7  : CONSTANT LP;
  61           C8  : CONSTANT LP;
  62           C9  : CONSTANT LP;
  63           C10 : CONSTANT LP;
  64           C11 : CONSTANT LP;
  65           C12 : CONSTANT LP;
  66           C13 : CONSTANT LP;
  67           C14 : CONSTANT LP;
  68
  69      PRIVATE
  70
  71           TYPE LP IS NEW INTEGER;
  72
  73           C1  : CONSTANT LP :=  1;
  74           C2  : CONSTANT LP :=  2;
  75           C3  : CONSTANT LP :=  3;
  76           C4  : CONSTANT LP :=  4;
  77           C5  : CONSTANT LP :=  5;
  78           C6  : CONSTANT LP :=  6;
  79           C7  : CONSTANT LP :=  7;
  80           C8  : CONSTANT LP :=  8;
  81           C9  : CONSTANT LP :=  9;
  82           C10 : CONSTANT LP := 10;
  83           C11 : CONSTANT LP := 11;
  84           C12 : CONSTANT LP := 12;
  85           C13 : CONSTANT LP := 13;
  86           C14 : CONSTANT LP := 14;
  87
  88      END PKG_L;
  89
  90      USE PKG_L;
  91
  92      SUBTYPE COMPONENT IS LP;
  93
  94      PACKAGE PKG_P IS
  95
  96           FIRST : CONSTANT := 0;
  97           LAST  : CONSTANT := 10;
  98
  99           SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
 100
 101           TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF
 102                                COMPONENT;
 103
 104           FUNCTION CREATE ( F1, L1 : INDEX;
 105                             F2, L2 : INDEX;
 106                             C      : COMPONENT;
 107                             DUMMY  : PARENT   -- TO RESOLVE OVERLOADING.
 108                           ) RETURN PARENT;
 109
 110           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN;
 111
 112           FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT;
 113
 114           FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT;
 115
 116           FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
 117                         RETURN PARENT;
 118
 119           FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
 120                         RETURN PARENT;
 121
 122      END PKG_P;
 123
 124      USE PKG_P;
 125
 126      TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5),
 127                            IDENT_INT (6) .. IDENT_INT (8));
 128
 129      X : T;
 130      W : PARENT (4 .. 5, 6 .. 8);
 131      C : COMPONENT;
 132      B : BOOLEAN := FALSE;
 133      N : CONSTANT := 2;
 134
 135      PROCEDURE A (X : ADDRESS) IS
 136      BEGIN
 137           B := IDENT_BOOL (TRUE);
 138      END A;
 139
 140      FUNCTION V RETURN T IS
 141           RESULT : T;
 142      BEGIN
 143           FOR I IN RESULT'RANGE LOOP
 144                FOR J IN RESULT'RANGE(2) LOOP
 145                     ASSIGN (RESULT (I, J), C);
 146                END LOOP;
 147           END LOOP;
 148           RETURN RESULT;
 149      END V;
 150
 151      PACKAGE BODY PKG_L IS
 152
 153           FUNCTION CREATE (X : INTEGER) RETURN LP IS
 154           BEGIN
 155                RETURN LP (IDENT_INT (X));
 156           END CREATE;
 157
 158           FUNCTION VALUE (X : LP) RETURN INTEGER IS
 159           BEGIN
 160                RETURN INTEGER (X);
 161           END VALUE;
 162
 163           FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS
 164           BEGIN
 165                RETURN X = Y;
 166           END EQUAL;
 167
 168           PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS
 169           BEGIN
 170                X := Y;
 171           END ASSIGN;
 172
 173      END PKG_L;
 174
 175      PACKAGE BODY PKG_P IS
 176
 177           FUNCTION CREATE
 178              ( F1, L1 : INDEX;
 179                F2, L2 : INDEX;
 180                C      : COMPONENT;
 181                DUMMY  : PARENT
 182              ) RETURN PARENT
 183           IS
 184                A : PARENT (F1 .. L1, F2 .. L2);
 185                B : COMPONENT;
 186           BEGIN
 187                ASSIGN (B, C);
 188                FOR I IN F1 .. L1 LOOP
 189                     FOR J IN F2 .. L2 LOOP
 190                          ASSIGN (A (I, J), B);
 191                          ASSIGN (B, CREATE (VALUE (B) + 1));
 192                     END LOOP;
 193                END LOOP;
 194                RETURN A;
 195           END CREATE;
 196
 197           FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS
 198           BEGIN
 199                IF X'LENGTH /= Y'LENGTH OR
 200                   X'LENGTH(2) /= Y'LENGTH(2) THEN
 201                     RETURN FALSE;
 202                ELSE FOR I IN X'RANGE LOOP
 203                          FOR J IN X'RANGE(2) LOOP
 204                               IF NOT EQUAL (X (I, J),
 205                                             Y (I - X'FIRST + Y'FIRST,
 206                                                J - X'FIRST(2) +
 207                                                    Y'FIRST(2))) THEN
 208                                    RETURN FALSE;
 209                               END IF;
 210                          END LOOP;
 211                     END LOOP;
 212                END IF;
 213                RETURN TRUE;
 214           END EQUAL;
 215
 216           FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS
 217                X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
 218                            INDEX'FIRST .. INDEX'FIRST + 1);
 219           BEGIN
 220                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
 221                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
 222                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), C);
 223                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
 224                RETURN X;
 225           END AGGR;
 226
 227           FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS
 228                X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1,
 229                            INDEX'FIRST .. INDEX'FIRST + 2);
 230           BEGIN
 231                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
 232                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
 233                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 2), C);
 234                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), D);
 235                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
 236                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
 237                RETURN X;
 238           END AGGR;
 239
 240           FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT)
 241                         RETURN PARENT IS
 242                X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3,
 243                            INDEX'FIRST .. INDEX'FIRST + 1);
 244           BEGIN
 245                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
 246                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
 247                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), C);
 248                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D);
 249                ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST    ), E);
 250                ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F);
 251                ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST    ), G);
 252                ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H);
 253                RETURN X;
 254           END AGGR;
 255
 256           FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT)
 257                         RETURN PARENT IS
 258                X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2,
 259                            INDEX'FIRST .. INDEX'FIRST + 2);
 260           BEGIN
 261                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST    ), A);
 262                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 1), B);
 263                ASSIGN (X (INDEX'FIRST    , INDEX'FIRST + 2), C);
 264                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST    ), D);
 265                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E);
 266                ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F);
 267                ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST    ), G);
 268                ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H);
 269                ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I);
 270                RETURN X;
 271           END AGGR;
 272
 273      END PKG_P;
 274
 275 BEGIN
 276      TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 277                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 278                       "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
 279                       "TYPE IS A LIMITED TYPE.  THIS TEST IS PART 2 " &
 280                       "OF 2 TESTS WHICH COVER THE OBJECTIVE.  THE " &
 281                       "FIRST PART IS IN TEST C34005S");
 282
 283      ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1));
 284      ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2));
 285      ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3));
 286      ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4));
 287      ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5));
 288      ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6));
 289
 290      ASSIGN (W (4, 6), CREATE (1));
 291      ASSIGN (W (4, 7), CREATE (2));
 292      ASSIGN (W (4, 8), CREATE (3));
 293      ASSIGN (W (5, 6), CREATE (4));
 294      ASSIGN (W (5, 7), CREATE (5));
 295      ASSIGN (W (5, 8), CREATE (6));
 296
 297      ASSIGN (C, CREATE (2));
 298
 299      IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
 300           FAILED ("INCORRECT QUALIFICATION");
 301      END IF;
 302
 303      IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN
 304           FAILED ("INCORRECT SELF CONVERSION");
 305      END IF;
 306
 307      IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN
 308           FAILED ("INCORRECT CONVERSION FROM PARENT");
 309      END IF;
 310
 311      BEGIN
 312           IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR
 313              NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)),
 314                         AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN
 315                FAILED ("INCORRECT CONVERSION TO PARENT");
 316           END IF;
 317      EXCEPTION
 318           WHEN CONSTRAINT_ERROR =>
 319                FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " &
 320                        "TO PARENT");
 321           WHEN OTHERS =>
 322                FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " &
 323                        "TO PARENT");
 324      END;
 325
 326      IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN
 327           FAILED ("INCORRECT ""IN""");
 328      END IF;
 329
 330      IF X NOT IN T OR
 331         NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN
 332           FAILED ("INCORRECT ""NOT IN""");
 333      END IF;
 334
 335      RESULT;
 336 END C34005V;