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

   1 -- C37213B.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 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 C37213B 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 ("C37213B", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " &
  66                       "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " &
  67                       "AND DISCRIMINANTS HAVE DEFAULTS");
  68
  69 -- CASE B
  70
  71      DECLARE
  72           TYPE CONS (D3 : INTEGER := 1) IS
  73                RECORD
  74                     C1 : REC (D3, F1);       -- F1 EVALUATED
  75                END RECORD;
  76           CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED");
  77           X : CONS;             -- F1 NOT EVALUATED AGAIN
  78           Y : CONS;             -- F1 NOT EVALUATED AGAIN
  79           CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED");
  80      BEGIN
  81           IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN
  82                FAILED ("DISCRIMINANT VALUES NOT CORRECT");
  83           END IF;
  84      END;
  85
  86      F1_CONS := 12;
  87
  88      DECLARE
  89           TYPE CONS (D3 : INTEGER := 1) IS
  90                RECORD
  91                     C1 : REC(D3, F1);
  92                END RECORD;
  93      BEGIN
  94           BEGIN
  95                DECLARE
  96                     X : CONS;
  97                BEGIN
  98                     FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1");
  99                     IF X /= (1, (1, 1)) THEN
 100                          COMMENT ("SHOULDN'T GET HERE");
 101                     END IF;
 102                END;
 103           EXCEPTION
 104                WHEN CONSTRAINT_ERROR =>
 105                     NULL;
 106                WHEN OTHERS =>
 107                     FAILED ("UNEXPECTED EXCEPTION - 1");
 108           END;
 109
 110           BEGIN
 111                DECLARE
 112                     TYPE ACC_CONS IS ACCESS CONS;
 113                     X : ACC_CONS;
 114                BEGIN
 115                     X := NEW CONS;
 116                     FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2");
 117                     BEGIN
 118                          IF X.ALL /= (1, (1, 1)) THEN
 119                               COMMENT ("IRRELEVANT");
 120                          END IF;
 121                     END;
 122                EXCEPTION
 123                     WHEN CONSTRAINT_ERROR =>
 124                          NULL;
 125                     WHEN OTHERS =>
 126                          FAILED ("UNEXPECTED EXCEPTION RAISED - 2");
 127                END;
 128           EXCEPTION
 129                WHEN OTHERS =>
 130                     FAILED ("CONSTRAINT CHECKED TOO SOON - 2");
 131           END;
 132
 133           BEGIN
 134                DECLARE
 135                     SUBTYPE SCONS IS CONS;
 136                BEGIN
 137                     DECLARE
 138                          X : SCONS;
 139                     BEGIN
 140                          FAILED ("DISCRIMINANT CHECK NOT " &
 141                                  "PERFORMED - 3");
 142                          IF X /= (1, (1, 1)) THEN
 143                               COMMENT ("IRRELEVANT");
 144                          END IF;
 145                     END;
 146                EXCEPTION
 147                     WHEN CONSTRAINT_ERROR =>
 148                          NULL;
 149                     WHEN OTHERS =>
 150                          FAILED ("UNEXPECTED EXCEPTION RAISED - 3");
 151                END;
 152           EXCEPTION
 153                WHEN OTHERS =>
 154                     FAILED ("CONSTRAINT CHECKED TOO SOON - 3");
 155           END;
 156
 157           BEGIN
 158                DECLARE
 159                     TYPE ARR IS ARRAY (1..5) OF CONS;
 160                BEGIN
 161                     DECLARE
 162                          X : ARR;
 163                     BEGIN
 164                          FAILED ("DISCRIMINANT CHECK NOT " &
 165                                  "PERFORMED - 4");
 166                          IF X /= (1..5 => (1, (1, 1))) THEN
 167                               COMMENT ("IRRELEVANT");
 168                          END IF;
 169                     END;
 170                EXCEPTION
 171                     WHEN CONSTRAINT_ERROR =>
 172                          NULL;
 173                     WHEN OTHERS =>
 174                          FAILED ("UNEXPECTED EXCEPTION RAISED - 4");
 175                END;
 176           EXCEPTION
 177                WHEN OTHERS =>
 178                     FAILED ("CONSTRAINT CHECKED TOO SOON - 4");
 179           END;
 180
 181           BEGIN
 182                DECLARE
 183                     TYPE NREC IS
 184                          RECORD
 185                               C1 : CONS;
 186                          END RECORD;
 187                BEGIN
 188                     DECLARE
 189                          X : NREC;
 190                     BEGIN
 191                          FAILED ("DISCRIMINANT CHECK NOT " &
 192                                  "PERFORMED - 5");
 193                          IF X /= (C1 => (1, (1, 1))) THEN
 194                               COMMENT ("IRRELEVANT");
 195                          END IF;
 196                     END;
 197                EXCEPTION
 198                     WHEN CONSTRAINT_ERROR =>
 199                          NULL;
 200                     WHEN OTHERS =>
 201                          FAILED ("UNEXPECTED EXCEPTION RAISED - 5");
 202                END;
 203           EXCEPTION
 204                WHEN OTHERS =>
 205                     FAILED ("CONSTRAINT CHECKED TOO SOON - 5");
 206           END;
 207
 208           BEGIN
 209                DECLARE
 210                     TYPE DREC IS NEW CONS;
 211                BEGIN
 212                     DECLARE
 213                          X : DREC;
 214                     BEGIN
 215                          FAILED ("DISCRIMINANT CHECK NOT " &
 216                                  "PERFORMED - 6");
 217                          IF X /= (1, (1, 1)) THEN
 218                               COMMENT ("IRRELEVANT");
 219                          END IF;
 220                     END;
 221                EXCEPTION
 222                     WHEN CONSTRAINT_ERROR =>
 223                          NULL;
 224                     WHEN OTHERS =>
 225                          FAILED ("UNEXPECTED EXCEPTION RAISED - 6");
 226                END;
 227           EXCEPTION
 228                WHEN OTHERS =>
 229                     FAILED ("CONSTRAINT CHECKED TOO SOON - 6");
 230           END;
 231
 232      END;
 233
 234      RESULT;
 235
 236 EXCEPTION
 237      WHEN OTHERS =>
 238           FAILED ("CONSTRAINT CHECK DONE TOO EARLY");
 239           RESULT;
 240
 241 END C37213B;