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

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