gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c4/c46043b.ada

   1 -- C46043B.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 FOR CONVERSION TO AN
  26 -- UNCONSTRAINED ARRAY TYPE IF, FOR A NON-NULL DIMENSION OF THE
  27 -- OPERAND TYPE, ONE BOUND DOES NOT BELONG TO THE CORRESPONDING INDEX
  28 -- SUBTYPE OF THE TARGET TYPE.
  29
  30 -- R.WILLIAMS 9/8/86
  31
  32 WITH REPORT; USE REPORT;
  33 PROCEDURE C46043B IS
  34
  35      SUBTYPE SUBINT IS INTEGER RANGE IDENT_INT (0) .. IDENT_INT (9);
  36
  37 BEGIN
  38      TEST ( "C46043B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
  39                        "CONVERSION TO AN UNCONSTRAINED ARRAY TYPE " &
  40                        "IF, FOR A NON-NULL DIMENSION OF THE OPERAND " &
  41                        "TYPE, ONE BOUND DOES NOT BELONG TO THE " &
  42                        "CORRESPONDING INDEX SUBTYPE OF THE TARGET " &
  43                        "TYPE" );
  44
  45      DECLARE
  46           TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER;
  47           A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10));
  48
  49           TYPE ARR2 IS ARRAY (SUBINT RANGE <>) OF INTEGER;
  50
  51           PROCEDURE CHECK (A : ARR2) IS
  52           BEGIN
  53                FAILED ( "NO EXCEPTION RAISED WITH ONE DIMENSIONAL " &
  54                         "ARRAYS" );
  55           END CHECK;
  56
  57      BEGIN
  58           A1 := (A1'RANGE => 0);
  59           CHECK (ARR2 (A1));
  60      EXCEPTION
  61           WHEN CONSTRAINT_ERROR =>
  62                NULL;
  63           WHEN OTHERS =>
  64                FAILED ( "WRONG EXCEPTION RAISED WITH ONE " &
  65                         "DIMENSIONAL ARRAYS" );
  66      END;
  67
  68      DECLARE
  69           TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
  70                INTEGER;
  71           A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
  72                      IDENT_INT (1) .. IDENT_INT (1));
  73
  74           TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF
  75                INTEGER;
  76
  77           PROCEDURE CHECK (A : ARR2) IS
  78           BEGIN
  79                FAILED ( "NO EXCEPTION RAISED WITH TWO DIMENSIONAL " &
  80                         "ARRAYS" );
  81           END CHECK;
  82
  83      BEGIN
  84           A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
  85           CHECK (ARR2 (A1));
  86      EXCEPTION
  87           WHEN CONSTRAINT_ERROR =>
  88                NULL;
  89           WHEN OTHERS =>
  90                FAILED ( "WRONG EXCEPTION RAISED WITH TWO " &
  91                         "DIMENSIONAL ARRAYS" );
  92      END;
  93
  94      DECLARE
  95           TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
  96                INTEGER;
  97           A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
  98                      IDENT_INT (1) .. IDENT_INT (0));
  99
 100           TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF
 101                INTEGER;
 102
 103           PROCEDURE CHECK (A : ARR2) IS
 104           BEGIN
 105                FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 1" );
 106           END CHECK;
 107
 108      BEGIN
 109           A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
 110           CHECK (ARR2 (A1));
 111      EXCEPTION
 112           WHEN CONSTRAINT_ERROR =>
 113                NULL;
 114           WHEN OTHERS =>
 115                FAILED ( "WRONG EXCEPTION RAISED " &
 116                         "WITH NULL ARRAYS - 1" );
 117      END;
 118
 119      DECLARE
 120           TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
 121                INTEGER;
 122           A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10),
 123                      IDENT_INT (1) .. IDENT_INT (0));
 124
 125           SUBTYPE NOINT IS INTEGER
 126                RANGE IDENT_INT (1) .. IDENT_INT (0);
 127
 128           TYPE ARR2 IS ARRAY (SUBINT RANGE <>, NOINT RANGE <>) OF
 129                INTEGER;
 130
 131           PROCEDURE CHECK (A : ARR2) IS
 132           BEGIN
 133                FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 2" );
 134           END CHECK;
 135
 136      BEGIN
 137           A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0));
 138           CHECK (ARR2 (A1));
 139      EXCEPTION
 140           WHEN CONSTRAINT_ERROR =>
 141                NULL;
 142           WHEN OTHERS =>
 143                FAILED ( "WRONG EXCEPTION RAISED " &
 144                         "WITH NULL ARRAYS - 2" );
 145      END;
 146
 147      RESULT;
 148 END C46043B;