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

   1 -- C32107A.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 -- CHECK THAT OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR
  26 -- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION
  27 -- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE
  28 -- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT
  29 -- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY
  30 -- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE
  31 -- EVALUATED.
  32
  33 -- R.WILLIAMS 9/24/86
  34
  35 WITH REPORT; USE REPORT;
  36 PROCEDURE C32107A IS
  37
  38      BUMP : INTEGER := 0;
  39
  40      ORDER_CHECK : INTEGER;
  41
  42      G1, H1, I1 : INTEGER;
  43
  44      FIRST_CALL : BOOLEAN := TRUE;
  45
  46      TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  47
  48      TYPE ARR1_NAME IS ACCESS ARR1;
  49
  50      TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF
  51           INTEGER;
  52
  53      TYPE REC (D : INTEGER) IS
  54           RECORD
  55                COMP : INTEGER;
  56           END RECORD;
  57
  58      TYPE REC_NAME IS ACCESS REC;
  59
  60      FUNCTION F RETURN INTEGER IS
  61      BEGIN
  62           BUMP := BUMP + 1;
  63           RETURN BUMP;
  64      END F;
  65
  66      FUNCTION G RETURN INTEGER IS
  67      BEGIN
  68           BUMP := BUMP + 1;
  69           G1 := BUMP;
  70           RETURN BUMP;
  71      END G;
  72
  73      FUNCTION H RETURN INTEGER IS
  74      BEGIN
  75           BUMP := BUMP + 1;
  76           H1 := BUMP;
  77           RETURN BUMP;
  78      END H;
  79
  80      FUNCTION I RETURN INTEGER IS
  81      BEGIN
  82           IF FIRST_CALL THEN
  83                BUMP := BUMP + 1;
  84                I1 := BUMP;
  85                FIRST_CALL := FALSE;
  86           END IF;
  87           RETURN I1;
  88      END I;
  89
  90 BEGIN
  91      TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " &
  92                        "ELABORATED IN THE ORDER OF THEIR " &
  93                        "OCCURRENCE, I.E., THAT EXPRESSIONS " &
  94                        "ASSOCIATED WITH ONE DECLARATION (INCLUDING " &
  95                        "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " &
  96                        "EVALUATED BEFORE ANY EXPRESSION BELONGING " &
  97                        "TO THE NEXT DECLARATION.  ALSO, CHECK THAT " &
  98                        "EXPRESSIONS IN THE SUBTYPE INDICATION OR " &
  99                        "THE CONSTRAINED ARRAY DEFINITION ARE " &
 100                        "EVALUATED BEFORE ANY INITIALIZATION " &
 101                        "EXPRESSIONS ARE EVALUATED" );
 102
 103      DECLARE -- (A).
 104           I1 : INTEGER := 10000 * F;
 105           A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) :=
 106                (1 .. H1 => (G1 * 100, I * 10));
 107           I2 : CONSTANT INTEGER := F * 1000;
 108      BEGIN
 109           ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP;
 110           IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN
 111                COMMENT ( "ORDER_CHECK HAS VALUE " &
 112                           INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
 113           ELSE
 114                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 115                         "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " &
 116                         "15242 -- ACTUAL VALUE IS " &
 117                          INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
 118           END IF;
 119      END; -- (A).
 120
 121      BUMP := 0;
 122
 123      DECLARE -- (B).
 124           A : ARR2 (1 .. F, 1 .. F * 10);
 125           R : REC (G * 100) := (G1 * 100, F * 1000);
 126           I : INTEGER RANGE 1 .. H;
 127           S : REC (F * 10);
 128      BEGIN
 129           ORDER_CHECK :=
 130                A'LAST (1) + A'LAST (2) + R.D + R.COMP;
 131           IF (H1 + S.D = 65) AND
 132              (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN
 133                COMMENT ( "ORDER_CHECK HAS VALUE 65 " &
 134                           INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
 135           ELSE
 136                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 137                         "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " &
 138                         "65 4312 -- ACTUAL VALUE IS " &
 139                          INTEGER'IMAGE (H1 + S.D) &
 140                          INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
 141           END IF;
 142      END; -- (B).
 143
 144      BUMP := 0;
 145
 146      DECLARE -- (C).
 147           I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F;
 148           A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000;
 149      BEGIN
 150           ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000);
 151           IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN
 152                COMMENT ( "ORDER_CHECK HAS VALUE " &
 153                           INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
 154           ELSE
 155                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 156                         "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " &
 157                         "3412 -- ACTUAL VALUE IS " &
 158                          INTEGER'IMAGE (ORDER_CHECK) & " - (C)" );
 159           END IF;
 160      END; -- (C).
 161
 162      BUMP := 0;
 163      FIRST_CALL := TRUE;
 164
 165      DECLARE -- (D).
 166           A1 : ARRAY (1 .. G) OF REC (H * 10000) :=
 167                (1 .. G1 => (H1 * 10000, I * 100));
 168           R1 : CONSTANT REC := (F * 1000, F * 10);
 169
 170      BEGIN
 171           ORDER_CHECK :=
 172                A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP;
 173           IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR
 174              ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN
 175                COMMENT ( "ORDER_CHECK HAS VALUE " &
 176                           INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
 177           ELSE
 178                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 179                         "VALUE OF ORDER_CHECK SHOULD BE 25341, " &
 180                         "24351, 15342 OR 14352  -- ACTUAL VALUE IS " &
 181                          INTEGER'IMAGE (ORDER_CHECK) & " - (D)" );
 182           END IF;
 183      END; -- (D).
 184
 185      BUMP := 0;
 186
 187      DECLARE -- (E).
 188           A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10);
 189           R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000);
 190
 191      BEGIN
 192           ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP;
 193           IF ORDER_CHECK /= 4321 THEN
 194                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 195                         "VALUE OF ORDER_CHECK SHOULD BE 4321 " &
 196                         "-- ACTUAL VALUE IS " &
 197                          INTEGER'IMAGE (ORDER_CHECK) & " - (E)" );
 198           END IF;
 199      END; -- (E).
 200
 201      BUMP := 0;
 202      FIRST_CALL := TRUE;
 203
 204      DECLARE -- (F).
 205           A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 :=
 206                (1 .. G1 => I * 10);
 207           A2 : ARR1 (1 .. F * 1000);
 208      BEGIN
 209           ORDER_CHECK :=
 210                A1'LAST + (H1 * 100) + A1 (1) + A2'LAST;
 211           IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN
 212                COMMENT ( "ORDER_CHECK HAS VALUE " &
 213                           INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
 214           ELSE
 215                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 216                         "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " &
 217                         "4132 -- ACTUAL VALUE IS " &
 218                          INTEGER'IMAGE (ORDER_CHECK) & " - (F)" );
 219           END IF;
 220      END; -- (F).
 221
 222      BUMP := 0;
 223
 224      DECLARE -- (G).
 225           A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1);
 226           R1 : CONSTANT REC_NAME (H * 10) :=
 227                NEW REC'(H1 * 10, F * 100);
 228      BEGIN
 229           ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP;
 230           IF ORDER_CHECK /= 321 THEN
 231                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 232                         "VALUE OF ORDER_CHECK SHOULD BE 321 OR " &
 233                         "-- ACTUAL VALUE IS " &
 234                          INTEGER'IMAGE (ORDER_CHECK) & " - (G)" );
 235           END IF;
 236      END; -- (G).
 237
 238      BUMP := 0;
 239
 240      DECLARE -- (H).
 241           TYPE REC (D : INTEGER := F) IS
 242                RECORD
 243                     COMP : INTEGER := F * 10;
 244                END RECORD;
 245
 246           R1 : REC;
 247           R2 : REC (G * 100) := (G1 * 100, F * 1000);
 248      BEGIN
 249           ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP;
 250           IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
 251              ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN
 252                COMMENT ( "ORDER_CHECK HAS VALUE " &
 253                           INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
 254           ELSE
 255                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 256                         "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
 257                         "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
 258                          INTEGER'IMAGE (ORDER_CHECK) & " - (H)" );
 259           END IF;
 260      END; -- (H).
 261
 262      BUMP := 0;
 263
 264      DECLARE -- (I).
 265           TYPE REC2 (D1, D2 : INTEGER) IS
 266                RECORD
 267                     COMP : INTEGER;
 268                END RECORD;
 269
 270           R1 : REC2 (G  * 1000, H  * 10000) :=
 271                     (G1 * 1000, H1 * 10000, F * 100);
 272           R2 : REC2 (F, F * 10);
 273      BEGIN
 274           ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2;
 275           IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR
 276              ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN
 277                COMMENT ( "ORDER_CHECK HAS VALUE " &
 278                           INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
 279           ELSE
 280                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 281                         "VALUE OF ORDER_CHECK SHOULD BE 21354, " &
 282                         "21345, 12354, OR 12345 -- ACTUAL VALUE IS " &
 283                          INTEGER'IMAGE (ORDER_CHECK) & " - (I)" );
 284           END IF;
 285
 286      END; -- (I).
 287
 288      BUMP := 0;
 289
 290      DECLARE -- (J).
 291           PACKAGE P IS
 292                TYPE PRIV (D : INTEGER) IS PRIVATE;
 293
 294                P1 : CONSTANT PRIV;
 295                P2 : CONSTANT PRIV;
 296
 297                FUNCTION GET_A (P : PRIV) RETURN INTEGER;
 298           PRIVATE
 299                TYPE PRIV (D : INTEGER) IS
 300                     RECORD
 301                          COMP : INTEGER;
 302                     END RECORD;
 303                P1 : CONSTANT PRIV := (F , F * 10);
 304                P2 : CONSTANT PRIV := (F * 100, F * 1000);
 305           END P;
 306
 307           PACKAGE BODY P IS
 308                FUNCTION GET_A (P : PRIV) RETURN INTEGER IS
 309                BEGIN
 310                     RETURN P.COMP;
 311                END GET_A;
 312           END P;
 313
 314           USE P;
 315      BEGIN
 316           ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2);
 317           IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
 318              ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
 319                COMMENT ( "ORDER_CHECK HAS VALUE " &
 320                           INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
 321           ELSE
 322                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 323                         "VALUE OF ORDER_CHECK SHOULD BE 4321, " &
 324                         "4312, 3421, OR 3412 -- ACTUAL VALUE IS " &
 325                          INTEGER'IMAGE (ORDER_CHECK) & " - (J)" );
 326           END IF;
 327      END; -- (J).
 328
 329      BUMP := 0;
 330
 331      DECLARE -- (K).
 332           PACKAGE P IS
 333                TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE;
 334
 335           PRIVATE
 336                TYPE PRIV (D1, D2 : INTEGER) IS
 337                     RECORD
 338                          NULL;
 339                     END RECORD;
 340           END P;
 341
 342           USE P;
 343
 344           P1 : PRIV (F, F * 10);
 345           P2 : PRIV (F * 100, F * 1000);
 346
 347      BEGIN
 348           ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2;
 349           IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR
 350              ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN
 351                COMMENT ( "ORDER_CHECK HAS VALUE " &
 352                           INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
 353           ELSE
 354                FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " &
 355                         "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " &
 356                         "3421, OR 3412 -- ACTUAL VALUE IS " &
 357                          INTEGER'IMAGE (ORDER_CHECK) & " - (K)" );
 358           END IF;
 359
 360      END; -- (K).
 361
 362      RESULT;
 363 END C32107A;