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

   1 -- C34005J.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 BOOLEAN TYPE.
  29
  30 -- HISTORY:
  31 --     JRK 9/16/86  CREATED ORIGINAL TEST.
  32 --     RJW 8/21/89  MODIFIED CHECKS FOR TYPE AND OBJECT SIZES.
  33 --     PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
  34
  35 WITH SYSTEM; USE SYSTEM;
  36 WITH REPORT; USE REPORT;
  37
  38 PROCEDURE C34005J IS
  39
  40      SUBTYPE COMPONENT IS BOOLEAN;
  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 => TRUE);
  66      W : PARENT (5 .. 7) := (OTHERS => TRUE);
  67      C : COMPONENT       := FALSE;
  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 := NOT 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 => FALSE);
 108      END IDENT;
 109
 110 BEGIN
 111      TEST ("C34005J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
 112                       "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
 113                       "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
 114                       "TYPE IS A BOOLEAN TYPE");
 115
 116      X := IDENT ((TRUE, FALSE, TRUE));
 117      IF X /= (TRUE, FALSE, TRUE) THEN
 118           FAILED ("INCORRECT :=");
 119      END IF;
 120
 121      IF T'(X) /= (TRUE, FALSE, TRUE) THEN
 122           FAILED ("INCORRECT QUALIFICATION");
 123      END IF;
 124
 125      IF T (X) /= (TRUE, FALSE, TRUE) THEN
 126           FAILED ("INCORRECT SELF CONVERSION");
 127      END IF;
 128
 129      IF EQUAL (3, 3) THEN
 130           W := (TRUE, FALSE, TRUE);
 131      END IF;
 132      IF T (W) /= (TRUE, FALSE, TRUE) THEN
 133           FAILED ("INCORRECT CONVERSION FROM PARENT");
 134      END IF;
 135
 136      BEGIN
 137           IF PARENT (X) /= (TRUE, FALSE, TRUE) OR
 138              PARENT (CREATE (2, 3, FALSE, X)) /= (FALSE, TRUE) 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 := (TRUE, FALSE, TRUE);
 150      END IF;
 151      IF T (U) /= (TRUE, FALSE, TRUE) THEN
 152           FAILED ("INCORRECT CONVERSION FROM ARRAY");
 153      END IF;
 154
 155      BEGIN
 156           IF ARR (X) /= (TRUE, FALSE, TRUE) OR
 157              ARRT (CREATE (1, 2, TRUE, X)) /= (TRUE, FALSE) 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 ((TRUE, FALSE, TRUE)) /= (TRUE, FALSE, TRUE) OR
 168         X = (TRUE, FALSE) THEN
 169           FAILED ("INCORRECT AGGREGATE");
 170      END IF;
 171
 172      BEGIN
 173           IF X (IDENT_INT (5)) /= TRUE OR
 174              CREATE (2, 3, FALSE, X) (3) /= TRUE THEN
 175                FAILED ("INCORRECT INDEX (VALUE)");
 176           END IF;
 177      EXCEPTION
 178           WHEN CONSTRAINT_ERROR =>
 179                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3");
 180           WHEN OTHERS =>
 181                FAILED ("CALL TO CREATE RAISED EXCEPTION - 3");
 182      END;
 183
 184      X (IDENT_INT (7)) := FALSE;
 185      IF X /= (TRUE, FALSE, FALSE) THEN
 186           FAILED ("INCORRECT INDEX (ASSIGNMENT)");
 187      END IF;
 188
 189      BEGIN
 190           X := IDENT ((TRUE, FALSE, TRUE));
 191           IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (FALSE, TRUE) OR
 192              CREATE (1, 4, FALSE, X) (1 .. 3) /=
 193              (FALSE, TRUE, FALSE) THEN
 194                FAILED ("INCORRECT SLICE (VALUE)");
 195           END IF;
 196      EXCEPTION
 197           WHEN CONSTRAINT_ERROR =>
 198                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4");
 199           WHEN OTHERS =>
 200                FAILED ("CALL TO CREATE RAISED EXCEPTION - 4");
 201      END;
 202
 203      X (IDENT_INT (5) .. IDENT_INT (6)) := (FALSE, TRUE);
 204      IF X /= (FALSE, TRUE, TRUE) THEN
 205           FAILED ("INCORRECT SLICE (ASSIGNMENT)");
 206      END IF;
 207
 208      BEGIN
 209           X := IDENT ((TRUE, FALSE, TRUE));
 210           IF NOT X /= (FALSE, TRUE, FALSE) OR
 211              NOT CREATE (2, 3, FALSE, X) /= (TRUE, FALSE) THEN
 212                FAILED ("INCORRECT ""NOT""");
 213           END IF;
 214      EXCEPTION
 215           WHEN CONSTRAINT_ERROR =>
 216                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5");
 217           WHEN OTHERS =>
 218                FAILED ("CALL TO CREATE RAISED EXCEPTION - 5");
 219      END;
 220
 221      BEGIN
 222           IF (X AND IDENT ((TRUE, TRUE, FALSE))) /=
 223              (TRUE, FALSE, FALSE) OR
 224              (CREATE (1, 4, FALSE, X) AND
 225              (FALSE, FALSE, TRUE, TRUE)) /=
 226              (FALSE, FALSE, FALSE, TRUE) THEN
 227                FAILED ("INCORRECT ""AND""");
 228           END IF;
 229      EXCEPTION
 230           WHEN CONSTRAINT_ERROR =>
 231                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6");
 232           WHEN OTHERS =>
 233                FAILED ("CALL TO CREATE RAISED EXCEPTION - 6");
 234      END;
 235
 236      BEGIN
 237           IF (X OR IDENT ((TRUE, FALSE, FALSE))) /=
 238              (TRUE, FALSE, TRUE) OR
 239              (CREATE (1, 4, FALSE, X) OR (FALSE, FALSE, TRUE, TRUE)) /=
 240              (FALSE, TRUE, TRUE, TRUE) THEN
 241                FAILED ("INCORRECT ""OR""");
 242           END IF;
 243      EXCEPTION
 244           WHEN CONSTRAINT_ERROR =>
 245                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7");
 246           WHEN OTHERS =>
 247                FAILED ("CALL TO CREATE RAISED EXCEPTION - 7");
 248      END;
 249
 250      BEGIN
 251           IF (X XOR IDENT ((TRUE, TRUE, FALSE))) /=
 252              (FALSE, TRUE, TRUE) OR
 253              (CREATE (1, 4, FALSE, X) XOR
 254              (FALSE, FALSE, TRUE, TRUE)) /=
 255              (FALSE, TRUE, TRUE, FALSE) THEN
 256                FAILED ("INCORRECT ""XOR""");
 257           END IF;
 258      EXCEPTION
 259           WHEN CONSTRAINT_ERROR =>
 260                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8");
 261           WHEN OTHERS =>
 262                FAILED ("CALL TO CREATE RAISED EXCEPTION - 8");
 263      END;
 264
 265      IF X = IDENT ((TRUE, FALSE, FALSE)) OR X = (TRUE, FALSE) THEN
 266           FAILED ("INCORRECT =");
 267      END IF;
 268
 269      IF X /= IDENT ((TRUE, FALSE, TRUE)) OR
 270         NOT (X /= (FALSE, TRUE)) THEN
 271           FAILED ("INCORRECT /=");
 272      END IF;
 273
 274      IF X < IDENT ((TRUE, FALSE, TRUE)) OR X < (TRUE, FALSE) THEN
 275           FAILED ("INCORRECT <");
 276      END IF;
 277
 278      IF X > IDENT ((TRUE, FALSE, TRUE)) OR X > (TRUE, TRUE) THEN
 279           FAILED ("INCORRECT >");
 280      END IF;
 281
 282      IF X <= IDENT ((TRUE, FALSE, FALSE)) OR
 283         X <= (TRUE, FALSE, FALSE, TRUE) THEN
 284           FAILED ("INCORRECT <=");
 285      END IF;
 286
 287      IF X >= IDENT ((TRUE, TRUE, FALSE)) OR
 288         X >= (TRUE, FALSE, TRUE, FALSE) THEN
 289           FAILED ("INCORRECT >=");
 290      END IF;
 291
 292      IF NOT (X IN T) OR (TRUE, FALSE) IN T THEN
 293           FAILED ("INCORRECT ""IN""");
 294      END IF;
 295
 296      IF X NOT IN T OR NOT ((TRUE, FALSE) NOT IN T) THEN
 297           FAILED ("INCORRECT ""NOT IN""");
 298      END IF;
 299
 300      BEGIN
 301           IF X & (FALSE, TRUE, FALSE) /=
 302              (TRUE, FALSE, TRUE, FALSE, TRUE, FALSE) OR
 303              CREATE (2, 3, FALSE, X) & (FALSE, TRUE) /=
 304              (FALSE, TRUE, FALSE, TRUE) THEN
 305                FAILED ("INCORRECT & (ARRAY, ARRAY)");
 306           END IF;
 307      EXCEPTION
 308           WHEN CONSTRAINT_ERROR =>
 309                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 9");
 310           WHEN OTHERS =>
 311                FAILED ("CALL TO CREATE RAISED EXCEPTION - 9");
 312      END;
 313
 314      BEGIN
 315           IF X & FALSE /= (TRUE, FALSE, TRUE, FALSE) OR
 316              CREATE (2, 3, FALSE, X) & FALSE /=
 317              (FALSE, TRUE, FALSE) THEN
 318                FAILED ("INCORRECT & (ARRAY, COMPONENT)");
 319           END IF;
 320      EXCEPTION
 321           WHEN CONSTRAINT_ERROR =>
 322                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 10");
 323           WHEN OTHERS =>
 324                FAILED ("CALL TO CREATE RAISED EXCEPTION - 10");
 325      END;
 326
 327      BEGIN
 328           IF FALSE & X /= (FALSE, TRUE, FALSE, TRUE) OR
 329              FALSE & CREATE (2, 3, TRUE, X) /=
 330              (FALSE, TRUE, FALSE) THEN
 331                FAILED ("INCORRECT & (COMPONENT, ARRAY)");
 332           END IF;
 333      EXCEPTION
 334           WHEN CONSTRAINT_ERROR =>
 335                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 11");
 336           WHEN OTHERS =>
 337                FAILED ("CALL TO CREATE RAISED EXCEPTION - 11");
 338      END;
 339
 340      IF EQUAL (3, 3) THEN
 341           C := FALSE;
 342      END IF;
 343
 344      BEGIN
 345           IF C & TRUE /= CREATE (2, 3, FALSE, X) THEN
 346                FAILED ("INCORRECT & (COMPONENT, COMPONENT)");
 347           END IF;
 348      EXCEPTION
 349           WHEN CONSTRAINT_ERROR =>
 350                FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 12");
 351           WHEN OTHERS =>
 352                FAILED ("CALL TO CREATE RAISED EXCEPTION - 12");
 353      END;
 354
 355      B := FALSE;
 356      A (X'ADDRESS);
 357      IF NOT B THEN
 358           FAILED ("INCORRECT 'ADDRESS");
 359      END IF;
 360
 361      IF T'FIRST /= 5 THEN
 362           FAILED ("INCORRECT TYPE'FIRST");
 363      END IF;
 364
 365      IF X'FIRST /= 5 THEN
 366           FAILED ("INCORRECT OBJECT'FIRST");
 367      END IF;
 368
 369      IF V'FIRST /= 5 THEN
 370           FAILED ("INCORRECT VALUE'FIRST");
 371      END IF;
 372
 373      IF T'FIRST (N) /= 5 THEN
 374           FAILED ("INCORRECT TYPE'FIRST (N)");
 375      END IF;
 376
 377      IF X'FIRST (N) /= 5 THEN
 378           FAILED ("INCORRECT OBJECT'FIRST (N)");
 379      END IF;
 380
 381      IF V'FIRST (N) /= 5 THEN
 382           FAILED ("INCORRECT VALUE'FIRST (N)");
 383      END IF;
 384
 385      IF T'LAST /= 7 THEN
 386           FAILED ("INCORRECT TYPE'LAST");
 387      END IF;
 388
 389      IF X'LAST /= 7 THEN
 390           FAILED ("INCORRECT OBJECT'LAST");
 391      END IF;
 392
 393      IF V'LAST /= 7 THEN
 394           FAILED ("INCORRECT VALUE'LAST");
 395      END IF;
 396
 397      IF T'LAST (N) /= 7 THEN
 398           FAILED ("INCORRECT TYPE'LAST (N)");
 399      END IF;
 400
 401      IF X'LAST (N) /= 7 THEN
 402           FAILED ("INCORRECT OBJECT'LAST (N)");
 403      END IF;
 404
 405      IF V'LAST (N) /= 7 THEN
 406           FAILED ("INCORRECT VALUE'LAST (N)");
 407      END IF;
 408
 409      IF T'LENGTH /= 3 THEN
 410           FAILED ("INCORRECT TYPE'LENGTH");
 411      END IF;
 412
 413      IF X'LENGTH /= 3 THEN
 414           FAILED ("INCORRECT OBJECT'LENGTH");
 415      END IF;
 416
 417      IF V'LENGTH /= 3 THEN
 418           FAILED ("INCORRECT VALUE'LENGTH");
 419      END IF;
 420
 421      IF T'LENGTH (N) /= 3 THEN
 422           FAILED ("INCORRECT TYPE'LENGTH (N)");
 423      END IF;
 424
 425      IF X'LENGTH (N) /= 3 THEN
 426           FAILED ("INCORRECT OBJECT'LENGTH (N)");
 427      END IF;
 428
 429      IF V'LENGTH (N) /= 3 THEN
 430           FAILED ("INCORRECT VALUE'LENGTH (N)");
 431      END IF;
 432
 433      DECLARE
 434           Y : PARENT (T'RANGE);
 435      BEGIN
 436           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 437                FAILED ("INCORRECT TYPE'RANGE");
 438           END IF;
 439      END;
 440
 441      DECLARE
 442           Y : PARENT (X'RANGE);
 443      BEGIN
 444           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 445                FAILED ("INCORRECT OBJECT'RANGE");
 446           END IF;
 447      END;
 448
 449      DECLARE
 450           Y : PARENT (V'RANGE);
 451      BEGIN
 452           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 453                FAILED ("INCORRECT VALUE'RANGE");
 454           END IF;
 455      END;
 456
 457      DECLARE
 458           Y : PARENT (T'RANGE (N));
 459      BEGIN
 460           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 461                FAILED ("INCORRECT TYPE'RANGE (N)");
 462           END IF;
 463      END;
 464
 465      DECLARE
 466           Y : PARENT (X'RANGE (N));
 467      BEGIN
 468           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 469                FAILED ("INCORRECT OBJECT'RANGE (N)");
 470           END IF;
 471      END;
 472
 473      DECLARE
 474           Y : PARENT (V'RANGE (N));
 475      BEGIN
 476           IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN
 477                FAILED ("INCORRECT VALUE'RANGE (N)");
 478           END IF;
 479      END;
 480
 481      RESULT;
 482 END C34005J;