old-autovect-branch/gcc/testsuite/ada/acats/tests/c4/c43211a.ada

   1 -- C43211A.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 IF A BOUND IN A NON-NULL
  26 -- RANGE OF A NON-NULL AGGREGATE DOES NOT BELONG TO THE INDEX SUBTYPE.
  27
  28 -- EG  02/06/84
  29 -- EG  05/08/85
  30 -- EDS 07/15/98    AVOID OPTIMIZATION
  31
  32 WITH REPORT;
  33
  34 PROCEDURE C43211A IS
  35
  36      USE REPORT;
  37
  38 BEGIN
  39
  40      TEST("C43211A","CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " &
  41                     "BOUND IN A NON-NULL RANGE OF A NON-NULL "    &
  42                     "AGGREGATE DOES NOT BELONG TO THE INDEX "     &
  43                     "SUBTYPE");
  44
  45      DECLARE
  46
  47           SUBTYPE ST IS INTEGER RANGE 4 .. 8;
  48           TYPE BASE IS ARRAY(ST RANGE <>, ST RANGE <>) OF INTEGER;
  49           SUBTYPE T IS BASE(5 .. 7, 5 .. 7);
  50
  51           A    : T;
  52
  53      BEGIN
  54
  55 CASE_A :  BEGIN
  56
  57                A := (6 .. 8 => (4 .. 6 => 0));
  58                IF A /= (6 .. 8 => (4 .. 6 => 0)) THEN
  59                     FAILED ("CASE A : INCORRECT VALUES");
  60                END IF;
  61
  62           EXCEPTION
  63
  64                WHEN OTHERS =>
  65                     FAILED ("EXCEPTION RAISED: CASE A");
  66
  67           END CASE_A;
  68
  69 CASE_B :  BEGIN
  70
  71                A := (6 .. IDENT_INT(8) =>
  72                      (IDENT_INT(4) .. 6 => 1));
  73                IF A /= (6 .. IDENT_INT(8) =>
  74                         (IDENT_INT(4) .. 6 => 1)) THEN
  75                     FAILED ("CASE B : INCORRECT VALUES");
  76                END IF;
  77
  78           EXCEPTION
  79
  80                WHEN OTHERS =>
  81                     FAILED ("EXCEPTION RAISED: CASE B");
  82
  83           END CASE_B;
  84
  85 CASE_C :  BEGIN
  86
  87                A := (7 .. 9 => (5 .. 7 => IDENT_INT(2)));
  88                FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE C " &
  89                 INTEGER'IMAGE(A(IDENT_INT(7),7)));
  90
  91           EXCEPTION
  92
  93                WHEN CONSTRAINT_ERROR =>
  94                     NULL;
  95
  96                WHEN OTHERS =>
  97                     FAILED ("EXCEPTION RAISED: CASE C");
  98
  99           END CASE_C;
 100
 101 CASE_D :  BEGIN
 102
 103                A := (5 .. 7 => (3 .. 5 => IDENT_INT(3)));
 104                FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE D " &
 105                 INTEGER'IMAGE(A(7,IDENT_INT(5))));
 106
 107           EXCEPTION
 108
 109                WHEN CONSTRAINT_ERROR =>
 110                     NULL;
 111
 112                WHEN OTHERS =>
 113                     FAILED ("EXCEPTION RAISED: CASE D");
 114
 115           END CASE_D;
 116
 117 CASE_E :  BEGIN
 118
 119                A := (7 .. IDENT_INT(9) => (5 .. 7 => IDENT_INT(4)));
 120                FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE E " &
 121                 INTEGER'IMAGE(A(IDENT_INT(7),7)));
 122
 123           EXCEPTION
 124
 125                WHEN CONSTRAINT_ERROR =>
 126                     NULL;
 127
 128                WHEN OTHERS =>
 129                     FAILED ("CASE E : EXCEPTION RAISED");
 130
 131           END CASE_E;
 132
 133 CASE_F :  BEGIN
 134
 135                A := (5 .. 7 => (IDENT_INT(3) .. 5 => IDENT_INT(5)));
 136                FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE F " &
 137                 INTEGER'IMAGE(A(7,IDENT_INT(5))));
 138
 139           EXCEPTION
 140
 141                WHEN CONSTRAINT_ERROR =>
 142                     NULL;
 143
 144                WHEN OTHERS =>
 145                     FAILED ("EXCEPTION RAISED: CASE F");
 146
 147           END CASE_F;
 148
 149 CASE_G :  BEGIN
 150
 151                A := (7 .. 8 => (5 .. 7 => IDENT_INT(6)),
 152               9 => (5 .. 7 => IDENT_INT(6)));
 153                FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE G " &
 154                 INTEGER'IMAGE(A(7,IDENT_INT(7))));
 155
 156           EXCEPTION
 157
 158                WHEN CONSTRAINT_ERROR =>
 159                     NULL;
 160
 161                WHEN OTHERS =>
 162                     FAILED ("EXCEPTION RAISED: CASE G");
 163
 164           END CASE_G;
 165
 166      END;
 167
 168      RESULT;
 169
 170 END C43211A;