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

   1 -- C36104B.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 CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE,
  26 -- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS,
  27 -- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES,
  28 -- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, WHERE
  29 -- AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE.
  30 -- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT
  31 -- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES.
  32 -- ONLY DYNAMIC CASES ARE CHECKED HERE.
  33
  34 -- DAT 2/3/81
  35 -- JRK 2/25/81
  36 -- L.BROWN  7/15/86  1) ADDED ACCESS TYPES.
  37 --                   2) DELETED "NULL INDEX RANGE, CONSTRAINT_ERROR
  38 --                      RAISED" SECTION.
  39 --                   3) MADE USE OF DYNAMIC-RESULT FUNCTIONS.
  40 --                   4) DELETED ALL REFERENCES TO CASE STATEMENT CHOICES
  41 --                      AND VARIANT PART CHOICES IN THE ABOVE COMMENT.
  42 -- EDS      7/16/98  AVOID OPTIMIZATION
  43
  44 WITH REPORT;
  45 PROCEDURE C36104B IS
  46
  47      USE REPORT;
  48
  49      TYPE WEEK IS (SSUN, SMON, STUE, SWED, STHU, SFRI, SSAT);
  50      SUN : WEEK := WEEK'VAL(IDENT_INT(0));
  51      MON : WEEK := WEEK'VAL(IDENT_INT(1));
  52      TUE : WEEK := WEEK'VAL(IDENT_INT(2));
  53      WED : WEEK := WEEK'VAL(IDENT_INT(3));
  54      THU : WEEK := WEEK'VAL(IDENT_INT(4));
  55      FRI : WEEK := WEEK'VAL(IDENT_INT(5));
  56      SAT : WEEK := WEEK'VAL(IDENT_INT(6));
  57      TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK;
  58      SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI;
  59      SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU;
  60
  61      TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10;
  62      TYPE I_10 IS NEW INT_10;
  63      SUBTYPE I_5 IS I_10 RANGE I_10(IDENT_INT(-5)) ..
  64                                I_10(IDENT_INT(5));
  65      TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5;
  66
  67      FUNCTION F(DAY : WEEK) RETURN WEEK IS
  68         BEGIN
  69           RETURN DAY;
  70         END;
  71
  72 BEGIN
  73      TEST ("C36104B", "CONSTRAINT_ERROR IS RAISED OR NOT IN DYNAMIC "
  74           & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS");
  75
  76      -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED.
  77
  78      BEGIN
  79           DECLARE
  80                TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5;
  81                -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
  82           BEGIN
  83                DECLARE
  84                   -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID
  85                   -- OPTIMIZATION OF SUBTYPE
  86                   A1 : A := (A'RANGE => I_5(IDENT_INT(1)));
  87                BEGIN
  88                   FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " &
  89                           I_5'IMAGE(A1(1)) );  --USE A1
  90                END;
  91           EXCEPTION
  92              --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS
  93              --REPORT FAILED.
  94              WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1");
  95           END;
  96      EXCEPTION
  97           WHEN CONSTRAINT_ERROR => NULL;
  98           WHEN OTHERS =>
  99                FAILED ("WRONG EXCEPTION RAISED 1");
 100      END;
 101
 102      BEGIN
 103           FOR I IN MID_WEEK RANGE MON .. MON LOOP
 104
 105                IF EQUAL(2,2)  THEN
 106                     SAT := SSAT;
 107                END IF;
 108
 109           END LOOP;
 110           FAILED ("CONSTRAINT_ERROR NOT RAISED 3");
 111      EXCEPTION
 112           WHEN CONSTRAINT_ERROR => NULL;
 113           WHEN OTHERS =>
 114                FAILED ("WRONG EXCEPTION RAISED 3");
 115      END;
 116
 117      BEGIN
 118           DECLARE
 119                TYPE P IS ACCESS I_5_ARRAY (0 .. 6);
 120                -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR.
 121           BEGIN
 122                DECLARE
 123                   TYPE PA IS NEW P;
 124                   -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID
 125                   -- OPTIMIZATION OF TYPE
 126                   PA1 : PA :=NEW I_5_ARRAY'(0.. I_5(IDENT_INT(6)) =>
 127                                             I_5(IDENT_INT(1)));
 128                BEGIN
 129                   FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " &
 130                           I_5'IMAGE(PA1(1))); --USE PA1
 131                END;
 132           EXCEPTION
 133              WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4");
 134           END;
 135      EXCEPTION
 136           WHEN CONSTRAINT_ERROR => NULL;
 137           WHEN OTHERS =>
 138                FAILED ("WRONG EXCEPTION RAISED 4");
 139      END;
 140
 141      DECLARE
 142           W : WEEK_ARRAY (MID_WEEK);
 143      BEGIN
 144           W := (MID_WEEK RANGE MON .. WED => WED);
 145           -- CONSTRAINT_ERROR RAISED.
 146           BEGIN
 147                FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " &
 148                        MID_WEEK'IMAGE(W(WED))); --USE W
 149           EXCEPTION
 150                WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 7");
 151           END;
 152      EXCEPTION
 153           WHEN CONSTRAINT_ERROR => NULL;
 154           WHEN OTHERS =>
 155                FAILED ("WRONG EXCEPTION RAISED 7");
 156      END;
 157
 158      DECLARE
 159           W : WEEK_ARRAY (WORK_WEEK);
 160      BEGIN
 161           W := (W'RANGE => WED); -- OK.
 162           W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION.
 163           BEGIN
 164                FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " &
 165                        MID_WEEK'IMAGE(W(WED))); --USE W
 166           EXCEPTION
 167                WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8");
 168           END;
 169      EXCEPTION
 170           WHEN CONSTRAINT_ERROR => NULL;
 171           WHEN OTHERS =>
 172                FAILED ("WRONG EXCEPTION RAISED 8");
 173      END;
 174
 175      BEGIN
 176           DECLARE
 177                W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI);
 178                -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR.
 179           BEGIN
 180                W(WED) := THU;        -- OK.
 181                FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " &
 182                        WEEK'IMAGE(W(WED)));   -- USE W
 183           END;
 184      EXCEPTION
 185           WHEN CONSTRAINT_ERROR => NULL;
 186           WHEN OTHERS =>
 187                FAILED ("WRONG EXCEPTION RAISED 9");
 188      END;
 189
 190      BEGIN
 191           DECLARE
 192                TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. WED);
 193                -- RAISES CONSTRAINT_ERROR.
 194           BEGIN
 195                DECLARE
 196                     X : W;              -- OK.
 197                BEGIN
 198                     X(TUE) := THU;   -- OK.
 199                     FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " &
 200                             WEEK'IMAGE(X(TUE)));   -- USE X
 201                END;
 202           EXCEPTION
 203                WHEN OTHERS =>
 204                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
 205           END;
 206      EXCEPTION
 207           WHEN CONSTRAINT_ERROR => NULL;
 208           WHEN OTHERS =>
 209                FAILED ("WRONG EXCEPTION RAISED 10");
 210      END;
 211
 212      BEGIN
 213           DECLARE
 214                SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. THU);
 215                -- RAISES CONSTRAINT_ERROR.
 216           BEGIN
 217                DECLARE
 218                     T : W;               -- OK.
 219                BEGIN
 220                     T(TUE) := THU;    -- OK.
 221                     FAILED ("CONSTRAINT_ERROR NOT RAISED 11 " &
 222                             WEEK'IMAGE(T(TUE)));
 223                END;
 224           EXCEPTION
 225                WHEN OTHERS =>
 226                     FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE");
 227           END;
 228      EXCEPTION
 229           WHEN CONSTRAINT_ERROR => NULL;
 230           WHEN OTHERS =>
 231                FAILED ("WRONG EXCEPTION RAISED 11");
 232      END;
 233
 234      -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED.
 235
 236      BEGIN
 237           DECLARE
 238                TYPE A IS ARRAY (I_5 RANGE I_5(IDENT_INT(-5)) .. -6) OF I_5;
 239                A1 : A;
 240           BEGIN
 241                IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN
 242                     FAILED ("'FIRST OF NULL ARRAY INCORRECT");
 243                END IF;
 244           END;
 245      EXCEPTION
 246           WHEN OTHERS => FAILED ("EXCEPTION RAISED 1");
 247      END;
 248
 249      BEGIN
 250           FOR I IN MID_WEEK RANGE SAT .. SUN LOOP
 251
 252                IF EQUAL(2,2)  THEN
 253                     TUE := STUE;
 254                END IF;
 255
 256           END LOOP;
 257           FOR I IN MID_WEEK RANGE FRI .. WED LOOP
 258
 259                IF EQUAL(2,2)  THEN
 260                     MON := SMON;
 261                END IF;
 262
 263           END LOOP;
 264           FOR I IN MID_WEEK RANGE MON .. SUN LOOP
 265
 266                IF EQUAL(3,3)  THEN
 267                     WED := SWED;
 268                END IF;
 269
 270           END LOOP;
 271           FOR I IN I_5 RANGE 10 .. -10 LOOP
 272
 273                IF EQUAL(2,2)  THEN
 274                     TUE := STUE;
 275                END IF;
 276
 277           END LOOP;
 278           FOR I IN I_5 RANGE 10 .. 9 LOOP
 279
 280                IF EQUAL(2,2)  THEN
 281                     THU := STHU;
 282                END IF;
 283
 284           END LOOP;
 285           FOR I IN I_5 RANGE -10 .. -11 LOOP
 286
 287                IF EQUAL(2,2)  THEN
 288                     SAT := SSAT;
 289                END IF;
 290
 291           END LOOP;
 292           FOR I IN I_5 RANGE -10 .. -20 LOOP
 293
 294                IF EQUAL(2,2)  THEN
 295                     SUN := SSUN;
 296                END IF;
 297
 298           END LOOP;
 299           FOR I IN I_5 RANGE 6 .. 5 LOOP
 300
 301                IF EQUAL(2,2)  THEN
 302                     MON := SMON;
 303                END IF;
 304
 305           END LOOP;
 306      EXCEPTION
 307           WHEN OTHERS => FAILED ("EXCEPTION RAISED 3");
 308      END;
 309
 310      BEGIN
 311           DECLARE
 312                TYPE P IS ACCESS I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6);
 313                PA1 : P := NEW I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6);
 314           BEGIN
 315                IF PA1'LENGTH /= IDENT_INT(0) THEN
 316                     FAILED ("'LENGTH OF NULL ARRAY INCORRECT");
 317                END IF;
 318           END;
 319      EXCEPTION
 320           WHEN OTHERS =>
 321                FAILED ("EXCEPTION RAISED 5");
 322      END;
 323
 324      DECLARE
 325           TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER;
 326           SUBTYPE SNARR IS INTEGER RANGE 1 .. 2;
 327           W : NARR(SNARR) := (1,2);
 328      BEGIN
 329           IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN
 330                FAILED("EVALUATION OF EXPRESSION IS INCORRECT");
 331           END IF;
 332      EXCEPTION
 333           WHEN OTHERS => FAILED ("EXCEPTION RAISED 7");
 334      END;
 335
 336      DECLARE
 337           W : WEEK_ARRAY (MID_WEEK);
 338      BEGIN
 339           W := (W'RANGE => WED); -- OK.
 340           W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN);
 341      EXCEPTION
 342           WHEN OTHERS => FAILED ("EXCEPTION RAISED 8");
 343      END;
 344
 345      BEGIN
 346           DECLARE
 347                W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN);
 348           BEGIN
 349
 350                IF EQUAL(W'LENGTH,0)  THEN
 351                     TUE := STUE;
 352                END IF;
 353
 354           END;
 355      EXCEPTION
 356           WHEN OTHERS => FAILED ("EXCEPTION RAISED 9");
 357      END;
 358
 359      BEGIN
 360           DECLARE
 361                TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
 362           BEGIN
 363
 364                IF EQUAL(W'LENGTH,0)  THEN
 365                     MON := SMON;
 366                END IF;
 367
 368           END;
 369      EXCEPTION
 370           WHEN OTHERS => FAILED ("EXCEPTION RAISED 10");
 371      END;
 372
 373      BEGIN
 374           DECLARE
 375                SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON);
 376           BEGIN
 377
 378                IF EQUAL(W'LENGTH,0)  THEN
 379                     WED := SWED;
 380                END IF;
 381
 382           END;
 383      EXCEPTION
 384           WHEN OTHERS => FAILED ("EXCEPTION RAISED 12");
 385      END;
 386
 387      -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED.
 388
 389      BEGIN
 390           IF F(SUN) IN  SAT .. SUN
 391           OR SAT IN  FRI .. WED
 392           OR F(WED) IN  THU .. TUE
 393           OR THU IN  MON .. SUN
 394           OR F(FRI) IN  SAT .. FRI
 395           OR WED IN  FRI .. MON
 396           THEN
 397                FAILED ("INCORRECT 'IN' EVALUATION 1");
 398           END IF;
 399
 400           IF IDENT_INT(0) IN  10 .. IDENT_INT(-10)
 401           OR 0 IN  IDENT_INT(10) .. 9
 402           OR IDENT_INT(0) IN  IDENT_INT(-10) .. -11
 403           OR 0 IN  -10 .. IDENT_INT(-20)
 404           OR IDENT_INT(0) IN  6 .. IDENT_INT(5)
 405           OR 0 IN  5 .. IDENT_INT(3)
 406           OR IDENT_INT(0) IN  7 .. IDENT_INT(3)
 407           THEN
 408                FAILED ("INCORRECT 'IN' EVALUATION 2");
 409           END IF;
 410
 411           IF F(WED) NOT IN  THU .. TUE
 412           AND IDENT_INT(0) NOT IN  IDENT_INT(4) .. -4
 413           THEN NULL;
 414           ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION");
 415           END IF;
 416      EXCEPTION
 417           WHEN OTHERS => FAILED ("EXCEPTION RAISED 52");
 418      END;
 419
 420      RESULT;
 421 END C36104B;