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

   1 -- C46054A.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 -- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE
  27 -- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT
  28 -- MATCH THOSE OF THE TARGET TYPE.
  29
  30 -- R.WILLIAMS 9/9/86
  31
  32 WITH REPORT; USE REPORT;
  33 PROCEDURE C46054A IS
  34
  35 BEGIN
  36      TEST ( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " &
  37                        "CONVERSION TO AN ACCESS SUBTYPE IF THE " &
  38                        "OPERAND VALUE IS NOT NULL AND THE " &
  39                        "DISCRIMINANTS OR INDEX BOUNDS OF THE " &
  40                        "DESIGNATED OBJECT DO NOT MATCH THOSE OF " &
  41                        "THE TARGET TYPE" );
  42
  43      DECLARE
  44           TYPE REC (D : INTEGER) IS
  45                RECORD
  46                     NULL;
  47                END RECORD;
  48
  49           TYPE ACREC IS ACCESS REC;
  50           A : ACREC (IDENT_INT (0)) := NEW REC (IDENT_INT (0));
  51
  52           SUBTYPE ACREC3 IS ACREC (IDENT_INT (3));
  53
  54           PROCEDURE PROC (A : ACREC) IS
  55                I : INTEGER;
  56           BEGIN
  57                I := IDENT_INT (A.D);
  58           END PROC;
  59
  60      BEGIN
  61           PROC (ACREC3 (A));
  62           FAILED ( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" );
  63      EXCEPTION
  64           WHEN CONSTRAINT_ERROR =>
  65                NULL;
  66           WHEN OTHERS =>
  67                FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" );
  68      END;
  69
  70      DECLARE
  71           TYPE REC (D1, D2 : INTEGER) IS
  72                RECORD
  73                     NULL;
  74                END RECORD;
  75
  76           TYPE ACREC IS ACCESS REC;
  77
  78           A : ACREC (IDENT_INT (3), IDENT_INT (1)) :=
  79               NEW REC (IDENT_INT (3), IDENT_INT (1));
  80
  81           SUBTYPE ACREC13 IS ACREC (IDENT_INT (1), IDENT_INT (3));
  82
  83           PROCEDURE PROC (A : ACREC) IS
  84                I : INTEGER;
  85           BEGIN
  86                I := IDENT_INT (A.D1);
  87           END PROC;
  88
  89      BEGIN
  90           PROC (ACREC13 (A));
  91           FAILED ( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" );
  92      EXCEPTION
  93           WHEN CONSTRAINT_ERROR =>
  94                NULL;
  95           WHEN OTHERS =>
  96                FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" );
  97      END;
  98
  99      DECLARE
 100           TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
 101
 102           TYPE ACARR IS ACCESS ARR;
 103           A : ACARR (IDENT_INT (0) .. IDENT_INT (1)) :=
 104               NEW ARR'(IDENT_INT (0) .. IDENT_INT (1) => 0);
 105
 106           SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2));
 107
 108           PROCEDURE PROC (A : ACARR) IS
 109                I : INTEGER;
 110           BEGIN
 111                I := IDENT_INT (A'LAST);
 112           END PROC;
 113
 114      BEGIN
 115           PROC (ACARR02 (A));
 116           FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02 (A)'" );
 117      EXCEPTION
 118           WHEN CONSTRAINT_ERROR =>
 119                NULL;
 120           WHEN OTHERS =>
 121                FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02 (A)'" );
 122      END;
 123
 124      DECLARE
 125           TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF
 126                INTEGER;
 127
 128           TYPE ACARR IS ACCESS ARR;
 129           A : ACARR (IDENT_INT (1) .. IDENT_INT (0),
 130                      IDENT_INT (4) .. IDENT_INT (5)) :=
 131               NEW ARR'(IDENT_INT (1) .. IDENT_INT (0) =>
 132                       (IDENT_INT (4) .. IDENT_INT (5) => 0));
 133
 134           SUBTYPE NACARR IS ACARR (IDENT_INT (0) .. IDENT_INT (1),
 135                                    IDENT_INT (5) .. IDENT_INT (4));
 136
 137           PROCEDURE PROC (A : NACARR) IS
 138                I : INTEGER;
 139           BEGIN
 140                I := IDENT_INT (A'LAST (1));
 141           END PROC;
 142
 143      BEGIN
 144           PROC (NACARR (A));
 145           FAILED ( "NO EXCEPTION RAISED FOR 'NACARR (A)'" );
 146      EXCEPTION
 147           WHEN CONSTRAINT_ERROR =>
 148                NULL;
 149           WHEN OTHERS =>
 150                FAILED ( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" );
 151      END;
 152
 153      DECLARE
 154           PACKAGE PKG1 IS
 155                TYPE PRIV (D : INTEGER) IS PRIVATE;
 156                TYPE ACPRV IS ACCESS PRIV;
 157                SUBTYPE ACPRV3 IS ACPRV (IDENT_INT (3));
 158
 159           PRIVATE
 160                TYPE PRIV (D : INTEGER) IS
 161                     RECORD
 162                          NULL;
 163                END RECORD;
 164           END PKG1;
 165
 166           USE PKG1;
 167
 168           PACKAGE PKG2 IS
 169                A : ACPRV (IDENT_INT (0)) := NEW PRIV (IDENT_INT (0));
 170           END PKG2;
 171
 172           USE PKG2;
 173
 174           PROCEDURE PROC (A : ACPRV) IS
 175                I : INTEGER;
 176           BEGIN
 177                I := IDENT_INT (A.D);
 178           END PROC;
 179
 180      BEGIN
 181           PROC (ACPRV3 (A));
 182           FAILED ( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" );
 183      EXCEPTION
 184           WHEN CONSTRAINT_ERROR =>
 185                NULL;
 186           WHEN OTHERS =>
 187                FAILED ( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" );
 188      END;
 189
 190      RESULT;
 191 END C46054A;