gcc/testsuite/ada/acats/tests/c4/c43004a.ada

   1 -- C43004A.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 -- OBJECTIVE:
  26 --     CHECK THAT CONSTRAINT_ERROR IS RAISED IF A VALUE FOR A
  27 --     NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT
  28 --     WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE.
  29
  30 -- HISTORY:
  31 --     BCB 01/22/88  CREATED ORIGINAL TEST.
  32 --     RJW 06/27/90  CORRECTED CONSTRAINTS OF TYPE DFIX.
  33 --     LDC 09/25/90  ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN
  34 --                   NOT OPTIMIZE IT AWAY,  ALSO INITIALIZED EACH
  35 --                   OBJECT TO VALID DATA BEFORE DOING THE INVALID,
  36 --                   MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN
  37 --                   NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE
  38 --                   FOR A CONSTRAINT ERROR IN IS PLACE.
  39 --     JRL 06/07/96  Changed value in aggregate in subtest 4 to value
  40 --                   guaranteed to be in the base range of the type FIX.
  41 --                   Corrected typo.
  42
  43 WITH REPORT; USE REPORT;
  44
  45 PROCEDURE C43004A IS
  46
  47      TYPE INT IS RANGE 1 .. 8;
  48      SUBTYPE SINT IS INT RANGE 2 .. 7;
  49
  50      TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE);
  51      SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN;
  52
  53      TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0;
  54      SUBTYPE SFL IS FL RANGE 1.0 .. 9.0;
  55
  56      TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0;
  57      SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0;
  58
  59      TYPE DINT IS NEW INTEGER RANGE 1 .. 8;
  60      SUBTYPE SDINT IS DINT RANGE 2 .. 7;
  61
  62      TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE;
  63      SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN;
  64
  65      TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0;
  66      SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0;
  67
  68      TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5;
  69      SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0;
  70
  71      TYPE REC1 IS RECORD
  72            E1, E2, E3, E4, E5 : SENUM;
  73      END RECORD;
  74
  75      TYPE REC2 IS RECORD
  76            E1, E2, E3, E4, E5 : SFIX;
  77      END RECORD;
  78
  79      TYPE REC3 IS RECORD
  80            E1, E2, E3, E4, E5 : SDENUM;
  81      END RECORD;
  82
  83      TYPE REC4 IS RECORD
  84            E1, E2, E3, E4, E5 : SDFIX;
  85      END RECORD;
  86
  87      ARRAY_OBJ : ARRAY(1..2) OF INTEGER;
  88
  89      A  : ARRAY(1..5) OF SINT;
  90      B  : REC1;
  91      C  : ARRAY(1..5) OF SFL;
  92      D  : REC2;
  93      E  : ARRAY(1..5) OF SDINT;
  94      F  : REC3;
  95      G  : ARRAY(1..5) OF SDFL;
  96      H  : REC4;
  97
  98      GENERIC
  99           TYPE GENERAL_PURPOSE IS PRIVATE;
 100      FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN;
 101
 102      FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS
 103      BEGIN
 104           IF EQUAL(3,3) THEN
 105                RETURN ONE = TWO;
 106           ELSE
 107                RETURN ONE /= TWO;
 108           END IF;
 109      END GENEQUAL;
 110
 111      FUNCTION EQUAL IS NEW GENEQUAL(SENUM);
 112      FUNCTION EQUAL IS NEW GENEQUAL(SFL);
 113      FUNCTION EQUAL IS NEW GENEQUAL(SFIX);
 114      FUNCTION EQUAL IS NEW GENEQUAL(SDENUM);
 115      FUNCTION EQUAL IS NEW GENEQUAL(SDFL);
 116      FUNCTION EQUAL IS NEW GENEQUAL(SDFIX);
 117
 118      GENERIC
 119           TYPE GENERAL_PURPOSE IS PRIVATE;
 120           WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE)
 121                    RETURN BOOLEAN;
 122      FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE;
 123      FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS
 124           BEGIN
 125           IF EQUAL_GENERAL (X, X) THEN  -- ALWAYS EQUAL.
 126                RETURN X;                -- ALWAYS EXECUTED.
 127           END IF;
 128                                         -- NEVER EXECUTED.
 129           RETURN X;
 130      END GEN_IDENT;
 131
 132      FUNCTION IDENT_FL    IS NEW GEN_IDENT(FL, EQUAL);
 133      FUNCTION IDENT_FIX   IS NEW GEN_IDENT(FIX, EQUAL);
 134      FUNCTION IDENT_DFL   IS NEW GEN_IDENT(DFL, EQUAL);
 135      FUNCTION IDENT_DFIX  IS NEW GEN_IDENT(DFIX, EQUAL);
 136
 137 BEGIN
 138      TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " &
 139                       "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " &
 140                       "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " &
 141                       "THE COMPONENT'S SUBTYPE");
 142
 143      ARRAY_OBJ := (1, 2);
 144
 145      BEGIN
 146           A  := (2,3,4,5,6);            -- OK
 147
 148           IF EQUAL (INTEGER (A(IDENT_INT(1))),
 149                     INTEGER (A(IDENT_INT(2)))) THEN
 150                COMMENT ("DON'T OPTIMIZE A");
 151           END IF;
 152
 153           A := (SINT(IDENT_INT(1)),2,3,4,7);
 154                                        -- CONSTRAINT_ERROR BY AGGREGATE
 155                                        -- WITH INTEGER COMPONENTS.
 156           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1");
 157           IF EQUAL (INTEGER (A(IDENT_INT(1))),
 158                     INTEGER (A(IDENT_INT(1)))) THEN
 159                COMMENT ("DON'T OPTIMIZE A");
 160           END IF;
 161      EXCEPTION
 162           WHEN CONSTRAINT_ERROR =>
 163                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 164                          ARRAY_OBJ(IDENT_INT(2))) THEN
 165                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 166                END IF;
 167           WHEN OTHERS =>
 168                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 169                        "WAS RAISED - 1");
 170      END;
 171
 172      BEGIN
 173           B := (JOHN,TOM,PHIL,ROSA,JOHN);  -- OK
 174
 175           IF EQUAL (B.E1, B.E2) THEN
 176                COMMENT ("DON'T OPTIMIZE B");
 177           END IF;
 178
 179           B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL,
 180                 ROSA, JODIE);
 181                                        -- CONSTRAINT_ERROR BY AGGREGATE
 182                                        -- WITH COMPONENTS OF AN
 183                                        -- ENUMERATION TYPE.
 184           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2");
 185           IF NOT EQUAL (B.E1, B.E1) THEN
 186                COMMENT ("DON'T OPTIMIZE B");
 187           END IF;
 188      EXCEPTION
 189           WHEN CONSTRAINT_ERROR =>
 190                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 191                          ARRAY_OBJ(IDENT_INT(2))) THEN
 192                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 193                END IF;
 194           WHEN OTHERS =>
 195                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 196                        "WAS RAISED - 2");
 197      END;
 198      BEGIN
 199           C := (2.0,3.0,4.0,5.0,6.0);  -- OK
 200           IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN
 201                COMMENT ("DON'T OPTIMIZE C");
 202           END IF;
 203
 204           C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0));
 205                                       -- CONSTRAINT_ERROR BY AGGREGATE
 206                                       -- WITH FLOATING POINT COMPONENTS.
 207           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3");
 208           IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN
 209                COMMENT ("DON'T OPTIMIZE C");
 210           END IF;
 211      EXCEPTION
 212           WHEN CONSTRAINT_ERROR =>
 213                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 214                          ARRAY_OBJ(IDENT_INT(2))) THEN
 215                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 216                END IF;
 217           WHEN OTHERS =>
 218                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 219                        "WAS RAISED - 3");
 220      END;
 221
 222      BEGIN
 223           D := (2.2,3.3,4.4,5.5,6.6); -- OK
 224           IF EQUAL (D.E1, D.E5) THEN
 225                COMMENT ("DON'T OPTIMIZE D");
 226           END IF;
 227
 228           D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75));
 229                                        -- CONSTRAINT_ERROR BY AGGREGATE
 230                                        -- WITH FIXED POINT COMPONENTS.
 231           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4");
 232           IF NOT EQUAL (D.E5, D.E5) THEN
 233                COMMENT ("DON'T OPTIMIZE D");
 234           END IF;
 235      EXCEPTION
 236           WHEN CONSTRAINT_ERROR =>
 237                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 238                          ARRAY_OBJ(IDENT_INT(2))) THEN
 239                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 240                END IF;
 241           WHEN OTHERS =>
 242                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 243                        "WAS RAISED - 4");
 244      END;
 245
 246      BEGIN
 247           E := (2,3,4,5,6); -- OK
 248           IF EQUAL (INTEGER (E(IDENT_INT(1))),
 249                     INTEGER (E(IDENT_INT(2)))) THEN
 250                COMMENT ("DON'T OPTIMIZE E");
 251           END IF;
 252
 253           E := (SDINT(IDENT_INT(1)),2,3,4,7);
 254                                      -- CONSTRAINT_ERROR BY AGGREGATE
 255                                      -- WITH DERIVED INTEGER COMPONENTS.
 256           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5");
 257           IF NOT EQUAL (INTEGER (E(IDENT_INT(1))),
 258                         INTEGER (E(IDENT_INT(1)))) THEN
 259                COMMENT ("DON'T OPTIMIZE E");
 260           END IF;
 261      EXCEPTION
 262           WHEN CONSTRAINT_ERROR =>
 263                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 264                          ARRAY_OBJ(IDENT_INT(2))) THEN
 265                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 266                END IF;
 267           WHEN OTHERS =>
 268                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 269                        "WAS RAISED - 5");
 270      END;
 271
 272      BEGIN
 273           F := (JOHN,TOM,PHIL,ROSA,JOHN);  -- OK
 274           IF EQUAL (F.E1, F.E2) THEN
 275                COMMENT ("DON'T OPTIMIZE F");
 276           END IF;
 277
 278           F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL,
 279                 ROSA, JODIE);
 280                                        -- CONSTRAINT_ERROR BY AGGREGATE
 281                                        -- WITH COMPONENTS OF A DERIVED
 282                                        -- ENUMERATION TYPE.
 283           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6");
 284           IF NOT EQUAL (F.E1, F.E1) THEN
 285                COMMENT ("DON'T OPTIMIZE F");
 286           END IF;
 287      EXCEPTION
 288           WHEN CONSTRAINT_ERROR =>
 289                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 290                          ARRAY_OBJ(IDENT_INT(2))) THEN
 291                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 292                END IF;
 293           WHEN OTHERS =>
 294                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 295                        "WAS RAISED - 6");
 296      END;
 297
 298      BEGIN
 299           G := (2.0,3.0,4.0,5.0,6.0); -- OK
 300           IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN
 301                COMMENT ("DON'T OPTIMIZE G");
 302           END IF;
 303
 304           G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0));
 305                                        -- CONSTRAINT_ERROR BY AGGREGATE
 306                                        -- WITH DERIVED FLOATING POINT
 307                                        -- COMPONENTS.
 308           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7");
 309           IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN
 310                COMMENT ("DON'T OPTIMIZE G");
 311           END IF;
 312      EXCEPTION
 313           WHEN CONSTRAINT_ERROR =>
 314                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 315                          ARRAY_OBJ(IDENT_INT(2))) THEN
 316                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 317                END IF;
 318           WHEN OTHERS =>
 319                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 320                        "WAS RAISED - 7");
 321      END;
 322
 323      BEGIN
 324           H := (2.2,3.3,4.4,5.5,6.6); -- OK
 325           IF EQUAL (H.E1, H.E2) THEN
 326                COMMENT ("DON'T OPTIMIZE H");
 327           END IF;
 328
 329           H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4));
 330                                        -- CONSTRAINT_ERROR BY AGGREGATE
 331                                        -- WITH DERIVED FIXED POINT
 332                                        -- COMPONENTS.
 333           FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8");
 334           IF EQUAL (H.E1, H.E5) THEN
 335                COMMENT ("DON'T OPTIMIZE H");
 336           END IF;
 337      EXCEPTION
 338           WHEN CONSTRAINT_ERROR =>
 339                IF EQUAL (ARRAY_OBJ(IDENT_INT(1)),
 340                          ARRAY_OBJ(IDENT_INT(2))) THEN
 341                     COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER");
 342                END IF;
 343           WHEN OTHERS =>
 344                FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " &
 345                        "WAS RAISED - 8");
 346      END;
 347
 348
 349      RESULT;
 350 END C43004A;