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

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