old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c34005s.ada

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