gcc/testsuite/ada/acats/tests/c3/c34005d.ada

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