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

   1 -- C37213D.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 --        AN INDEX 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 B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT
  32 --      DECLARATION.
  33
  34 -- JBG 10/17/86
  35
  36 WITH REPORT; USE REPORT;
  37 PROCEDURE C37213D IS
  38
  39      SUBTYPE SM IS INTEGER RANGE 1..10;
  40
  41      TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER;
  42
  43      F1_CONS : INTEGER := 2;
  44
  45      FUNCTION CHK (
  46           CONS    : INTEGER;
  47           VALUE   : INTEGER;
  48           MESSAGE : STRING) RETURN BOOLEAN IS
  49      BEGIN
  50           IF CONS /= VALUE THEN
  51                FAILED (MESSAGE & ": CONS IS " &
  52                        INTEGER'IMAGE(CONS));
  53           END IF;
  54           RETURN TRUE;
  55      END CHK;
  56
  57      FUNCTION F1 RETURN INTEGER IS
  58      BEGIN
  59           F1_CONS := F1_CONS - IDENT_INT(1);
  60           RETURN F1_CONS;
  61      END F1;
  62
  63 BEGIN
  64      TEST ("C37213D", "CHECK EVALUATION OF INDEX BOUNDS " &
  65                       "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
  66                       "AND DISCRIMINANTS HAVE DEFAULTS");
  67
  68 -- CASE B
  69
  70      DECLARE
  71           TYPE CONS (D3 : INTEGER := 1) IS
  72                RECORD
  73                     C1 : MY_ARR (F1..D3);    -- F1 EVALUATED.
  74                END RECORD;
  75           CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
  76           X : CONS;             -- F1 NOT EVALUATED AGAIN
  77           Y : CONS;             -- F1 NOT EVALUATED AGAIN
  78           CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
  79      BEGIN
  80           IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN
  81                FAILED ("INDEX BOUNDS NOT CORRECT");
  82           END IF;
  83      END;
  84
  85      F1_CONS := 12;
  86
  87      DECLARE
  88           TYPE CONS (D3 : INTEGER := 1) IS
  89                RECORD
  90                     C1 : MY_ARR(D3..F1);
  91                END RECORD;
  92      BEGIN
  93           BEGIN
  94                DECLARE
  95                     X : CONS;
  96                BEGIN
  97                     FAILED ("INDEX CHECK NOT PERFORMED - 1");
  98                     IF X /= (1, (1, 1)) THEN
  99                          COMMENT ("SHOULDN'T GET HERE");
 100                     END IF;
 101                END;
 102           EXCEPTION
 103                WHEN CONSTRAINT_ERROR =>
 104                     NULL;
 105                WHEN OTHERS =>
 106                     FAILED ("UNEXPECTED EXCEPTION - 1");
 107           END;
 108
 109           BEGIN
 110                DECLARE
 111                     TYPE ACC_CONS IS ACCESS CONS;
 112                     X : ACC_CONS;
 113                BEGIN
 114                     X := NEW CONS;
 115                     FAILED ("INDEX CHECK NOT PERFORMED - 2");
 116                     BEGIN
 117                          IF X.ALL /= (1, (1 => 1)) THEN
 118                               COMMENT ("IRRELEVANT");
 119                          END IF;
 120                     END;
 121                EXCEPTION
 122                     WHEN CONSTRAINT_ERROR =>
 123                          NULL;
 124                     WHEN OTHERS =>
 125                          FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
 126                END;
 127           EXCEPTION
 128                WHEN OTHERS =>
 129                     FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
 130           END;
 131
 132           BEGIN
 133                DECLARE
 134                     SUBTYPE SCONS IS CONS;
 135                BEGIN
 136                     DECLARE
 137                          X : SCONS;
 138                     BEGIN
 139                          FAILED ("INDEX CHECK NOT " &
 140                                  "PERFORMED - 3");
 141                          IF X /= (1, (1 => 1)) THEN
 142                               COMMENT ("IRRELEVANT");
 143                          END IF;
 144                     END;
 145                EXCEPTION
 146                     WHEN CONSTRAINT_ERROR =>
 147                          NULL;
 148                     WHEN OTHERS =>
 149                          FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
 150                END;
 151           EXCEPTION
 152                WHEN OTHERS =>
 153                     FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
 154           END;
 155
 156           BEGIN
 157                DECLARE
 158                     TYPE ARR IS ARRAY (1..5) OF CONS;
 159                BEGIN
 160                     DECLARE
 161                          X : ARR;
 162                     BEGIN
 163                          FAILED ("INDEX CHECK NOT " &
 164                                  "PERFORMED - 4");
 165                          IF X /= (1..5 => (1, (1 => 1))) THEN
 166                               COMMENT ("IRRELEVANT");
 167                          END IF;
 168                     END;
 169                EXCEPTION
 170                     WHEN CONSTRAINT_ERROR =>
 171                          NULL;
 172                     WHEN OTHERS =>
 173                          FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
 174                END;
 175           EXCEPTION
 176                WHEN OTHERS =>
 177                     FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
 178           END;
 179
 180           BEGIN
 181                DECLARE
 182                     TYPE NREC IS
 183                          RECORD
 184                               C1 : CONS;
 185                          END RECORD;
 186                BEGIN
 187                     DECLARE
 188                          X : NREC;
 189                     BEGIN
 190                          FAILED ("INDEX CHECK NOT " &
 191                                  "PERFORMED - 5");
 192                          IF X /= (C1 => (1, (1 => 1))) THEN
 193                               COMMENT ("IRRELEVANT");
 194                          END IF;
 195                     END;
 196                EXCEPTION
 197                     WHEN CONSTRAINT_ERROR =>
 198                          NULL;
 199                     WHEN OTHERS =>
 200                          FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
 201                END;
 202           EXCEPTION
 203                WHEN OTHERS =>
 204                     FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
 205           END;
 206
 207           BEGIN
 208                DECLARE
 209                     TYPE DREC IS NEW CONS;
 210                BEGIN
 211                     DECLARE
 212                          X : DREC;
 213                     BEGIN
 214                          FAILED ("INDEX CHECK NOT " &
 215                                  "PERFORMED - 6");
 216                          IF X /= (1, (1 => 1)) THEN
 217                               COMMENT ("IRRELEVANT");
 218                          END IF;
 219                     END;
 220                EXCEPTION
 221                     WHEN CONSTRAINT_ERROR =>
 222                          NULL;
 223                     WHEN OTHERS =>
 224                          FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
 225                END;
 226           EXCEPTION
 227                WHEN OTHERS =>
 228                     FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
 229           END;
 230
 231      END;
 232
 233      RESULT;
 234
 235 EXCEPTION
 236      WHEN OTHERS =>
 237           FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
 238           RESULT;
 239
 240 END C37213D;