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

   1 -- C37213F.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 IF
  26 --        A DISCRIMINANT CONSTRAINT
  27 -- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE
  28 -- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS
  29 -- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS:
  30 --
  31 --   CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
  32 --      DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE.
  33
  34 -- JBG 10/17/86
  35
  36 WITH REPORT; USE REPORT;
  37 PROCEDURE C37213F IS
  38
  39      SUBTYPE SM IS INTEGER RANGE 1..10;
  40
  41      TYPE REC (D1, D2 : SM) IS
  42           RECORD NULL; END RECORD;
  43
  44      F1_CONS : INTEGER := 2;
  45
  46      FUNCTION CHK (
  47           CONS    : INTEGER;
  48           VALUE   : INTEGER;
  49           MESSAGE : STRING) RETURN BOOLEAN IS
  50      BEGIN
  51           IF CONS /= VALUE THEN
  52                FAILED (MESSAGE & ": CONS IS " &
  53                        INTEGER'IMAGE(CONS));
  54           END IF;
  55           RETURN TRUE;
  56      END CHK;
  57
  58      FUNCTION F1 RETURN INTEGER IS
  59      BEGIN
  60           F1_CONS := F1_CONS - IDENT_INT(1);
  61           RETURN F1_CONS;
  62      END F1;
  63
  64 BEGIN
  65      TEST ("C37213F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
  66                       "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
  67                       "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT" &
  68                       "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " &
  69                       "BE CHECKED");
  70
  71 -- CASE D1: COMPONENT IS PRESENT
  72
  73      DECLARE
  74           TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
  75                RECORD
  76                     CASE D3 IS
  77                          WHEN -5..10 =>
  78                               C1 : REC (D3, F1);       -- F1 EVALUATED
  79                          WHEN OTHERS =>
  80                               C2 : INTEGER := IDENT_INT(0);
  81                     END CASE;
  82                END RECORD;
  83           CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
  84           X : CONS;             -- F1 NOT EVALUATED AGAIN
  85           Y : CONS;             -- F1 NOT EVALUATED AGAIN
  86           CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
  87      BEGIN
  88           IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
  89                FAILED ("DISCRIMINANT VALUES NOT CORRECT");
  90           END IF;
  91      END;
  92
  93      F1_CONS := 12;
  94
  95      DECLARE
  96           TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS
  97                RECORD
  98                     CASE D3 IS
  99                          WHEN -5..10 =>
 100                               C1 : REC(D3, F1);
 101                          WHEN OTHERS =>
 102                               C2 : INTEGER := IDENT_INT(0);
 103                     END CASE;
 104                END RECORD;
 105      BEGIN
 106           BEGIN
 107                DECLARE
 108                     X : CONS;
 109                BEGIN
 110                     FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
 111                     IF X /= (1, (1, 1)) THEN
 112                          COMMENT ("SHOULDN'T GET HERE");
 113                     END IF;
 114                END;
 115           EXCEPTION
 116                WHEN CONSTRAINT_ERROR =>
 117                     NULL;
 118                WHEN OTHERS =>
 119                     FAILED ("UNEXPECTED EXCEPTION - 1");
 120           END;
 121
 122           BEGIN
 123                DECLARE
 124                     TYPE ACC_CONS IS ACCESS CONS;
 125                     X : ACC_CONS;
 126                BEGIN
 127                     X := NEW CONS;
 128                     FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
 129                     IF X.ALL /= (1, (1, 1)) THEN
 130                          COMMENT ("IRRELEVANT");
 131                     END IF;
 132                EXCEPTION
 133                     WHEN CONSTRAINT_ERROR =>
 134                          NULL;
 135                     WHEN OTHERS =>
 136                          FAILED ("UNEXPECTED EXCEPTION RAISED - 2A");
 137                END;
 138           EXCEPTION
 139                WHEN OTHERS =>
 140                     FAILED ("UNEXPECTED EXCEPTION RAISED - 2B");
 141           END;
 142
 143           BEGIN
 144                DECLARE
 145                     SUBTYPE SCONS IS CONS;
 146                BEGIN
 147                     DECLARE
 148                          X : SCONS;
 149                     BEGIN
 150                          FAILED ("DISCRIMINANT CHECK NOT " &
 151                                  "PERFORMED - 3");
 152                          IF X /= (1, (1, 1)) THEN
 153                               COMMENT ("IRRELEVANT");
 154                          END IF;
 155                     END;
 156                EXCEPTION
 157                     WHEN CONSTRAINT_ERROR =>
 158                          NULL;
 159                     WHEN OTHERS =>
 160                          FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
 161                END;
 162           EXCEPTION
 163                WHEN OTHERS =>
 164                     FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
 165           END;
 166
 167           BEGIN
 168                DECLARE
 169                     TYPE ARR IS ARRAY (1..5) OF CONS;
 170                BEGIN
 171                     DECLARE
 172                          X : ARR;
 173                     BEGIN
 174                          FAILED ("DISCRIMINANT CHECK NOT " &
 175                                  "PERFORMED - 4");
 176                          IF X /= (1..5 => (1, (1, 1))) THEN
 177                               COMMENT ("IRRELEVANT");
 178                          END IF;
 179                     END;
 180                EXCEPTION
 181                     WHEN CONSTRAINT_ERROR =>
 182                          NULL;
 183                     WHEN OTHERS =>
 184                          FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
 185                END;
 186           EXCEPTION
 187                WHEN OTHERS =>
 188                     FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
 189           END;
 190
 191           BEGIN
 192                DECLARE
 193                     TYPE NREC IS
 194                          RECORD
 195                               C1 : CONS;
 196                          END RECORD;
 197                BEGIN
 198                     DECLARE
 199                          X : NREC;
 200                     BEGIN
 201                          FAILED ("DISCRIMINANT CHECK NOT " &
 202                                  "PERFORMED - 5");
 203                          IF X /= (C1 => (1, (1, 1))) THEN
 204                               COMMENT ("IRRELEVANT");
 205                          END IF;
 206                     END;
 207                EXCEPTION
 208                     WHEN CONSTRAINT_ERROR =>
 209                          NULL;
 210                     WHEN OTHERS =>
 211                          FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
 212                END;
 213           EXCEPTION
 214                WHEN OTHERS =>
 215                     FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
 216           END;
 217
 218           BEGIN
 219                DECLARE
 220                     TYPE DREC IS NEW CONS;
 221                BEGIN
 222                     DECLARE
 223                          X : DREC;
 224                     BEGIN
 225                          FAILED ("DISCRIMINANT CHECK NOT " &
 226                                  "PERFORMED - 6");
 227                          IF X /= (1, (1, 1)) THEN
 228                               COMMENT ("IRRELEVANT");
 229                          END IF;
 230                     END;
 231                EXCEPTION
 232                     WHEN CONSTRAINT_ERROR =>
 233                          NULL;
 234                     WHEN OTHERS =>
 235                          FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
 236                END;
 237           EXCEPTION
 238                WHEN OTHERS =>
 239                     FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
 240           END;
 241
 242      END;
 243
 244 -- CASE C2 : COMPONENT IS ABSENT
 245
 246      F1_CONS := 2;
 247
 248      DECLARE
 249           TYPE CONS (D3 : INTEGER := IDENT_INT(-6)) IS
 250                RECORD
 251                     CASE D3 IS
 252                          WHEN -5..10 =>
 253                               C1 : REC (D3, F1);       -- F1 EVALUATED
 254                          WHEN OTHERS =>
 255                               C2 : INTEGER := IDENT_INT(0);
 256                     END CASE;
 257                END RECORD;
 258           CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED - 2");
 259           X : CONS;             -- F1 NOT EVALUATED AGAIN
 260           Y : CONS;             -- F1 NOT EVALUATED AGAIN
 261           CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED - 2");
 262      BEGIN
 263           IF X /= (-6, 0) OR Y /= (-6, 0) THEN
 264                FAILED ("DISCRIMINANT VALUES NOT CORRECT");
 265           END IF;
 266      END;
 267
 268      F1_CONS := 12;
 269
 270      DECLARE
 271           TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS
 272                RECORD
 273                     CASE D3 IS
 274                          WHEN -5..10 =>
 275                               C1 : REC(D3, F1);
 276                          WHEN OTHERS =>
 277                               C2 : INTEGER := IDENT_INT(0);
 278                     END CASE;
 279                END RECORD;
 280      BEGIN
 281           BEGIN
 282                DECLARE
 283                     X : CONS;
 284                BEGIN
 285                     IF X /= (11, 0) THEN
 286                          FAILED ("WRONG VALUE FOR X - 11");
 287                     END IF;
 288                END;
 289           EXCEPTION
 290                WHEN OTHERS =>
 291                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11");
 292           END;
 293
 294           BEGIN
 295                DECLARE
 296                     SUBTYPE SCONS IS CONS;
 297                BEGIN
 298                     DECLARE
 299                          X : SCONS;
 300                     BEGIN
 301                          IF X /= (11, 0) THEN
 302                               FAILED ("X VALUE WRONG - 12");
 303                          END IF;
 304                     END;
 305                END;
 306           EXCEPTION
 307                WHEN OTHERS =>
 308                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12");
 309           END;
 310
 311           BEGIN
 312                DECLARE
 313                     TYPE ARR IS ARRAY (1..5) OF CONS;
 314                     X : ARR;
 315                BEGIN
 316                     IF X /= (1..5 => (11, 0)) THEN
 317                          FAILED ("X VALUE INCORRECT - 13");
 318                     END IF;
 319                END;
 320           EXCEPTION
 321                WHEN OTHERS =>
 322                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13");
 323           END;
 324
 325           BEGIN
 326                DECLARE
 327                     TYPE NREC IS
 328                          RECORD
 329                               C1 : CONS;
 330                          END RECORD;
 331                     X : NREC;
 332                BEGIN
 333                     IF X /= (C1 => (11, 0)) THEN
 334                          FAILED ("X VALUE IS INCORRECT - 14");
 335                     END IF;
 336                END;
 337           EXCEPTION
 338                WHEN OTHERS =>
 339                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14");
 340           END;
 341
 342           BEGIN
 343                DECLARE
 344                     TYPE NREC IS NEW CONS;
 345                     X : NREC;
 346                BEGIN
 347                     IF X /= (11, 0) THEN
 348                          FAILED ("X VALUE INCORRECT - 15");
 349                     END IF;
 350                END;
 351           EXCEPTION
 352                WHEN OTHERS =>
 353                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15");
 354           END;
 355
 356           BEGIN
 357                DECLARE
 358                     TYPE ACC_CONS IS ACCESS CONS;
 359                     X : ACC_CONS := NEW CONS;
 360                BEGIN
 361                     IF X.ALL /= (11, 0) THEN
 362                          FAILED ("X VALUE INCORRECT - 17");
 363                     END IF;
 364                END;
 365           EXCEPTION
 366                WHEN OTHERS =>
 367                     FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17");
 368           END;
 369      END;
 370
 371
 372      RESULT;
 373
 374 EXCEPTION
 375      WHEN OTHERS =>
 376           FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
 377           RESULT;
 378
 379 END C37213F;