gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c3/c37108b.ada

   1 -- C37108B.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 IN AN OBJECT DECLARATION IF
  26 -- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE
  27 -- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT
  28 -- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS
  29 -- PROVIDED FOR THE OBJECT.
  30
  31 -- R.WILLIAMS 8/25/86
  32 -- EDS        7/16/98    AVOID OPTIMIZATION
  33
  34 WITH REPORT; USE REPORT;
  35 PROCEDURE C37108B IS
  36
  37      TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER;
  38
  39      TYPE R (P : POSITIVE) IS
  40           RECORD
  41                NULL;
  42           END RECORD;
  43
  44 BEGIN
  45      TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " &
  46                        "AN OBJECT DECLARATION IF A DEFAULT INITIAL " &
  47                        "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " &
  48                        "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " &
  49                        "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " &
  50                        "AND NO EXPLICIT INITIALIZATION IS PROVIDED " &
  51                        "FOR THE OBJECT" );
  52
  53
  54      BEGIN
  55           DECLARE
  56                TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS
  57                     RECORD
  58                          A : ARR (D .. 5);
  59                     END RECORD;
  60
  61           BEGIN
  62                DECLARE
  63                     R1 : REC1;
  64
  65                BEGIN
  66                     R1.A (1) := IDENT_INT (2);
  67                     FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
  68                              "R1" & INTEGER'IMAGE(R1.A(5)));  --USE R2
  69                EXCEPTION
  70                     WHEN OTHERS =>
  71                          FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " &
  72                                   "BLOCK" );
  73                END;
  74
  75           EXCEPTION
  76                WHEN CONSTRAINT_ERROR =>
  77                     NULL;
  78                WHEN OTHERS =>
  79                     FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
  80                              "OF R1" );
  81           END;
  82
  83      EXCEPTION
  84           WHEN CONSTRAINT_ERROR =>
  85                FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
  86                         "DECLARATION OF REC1" );
  87           WHEN OTHERS =>
  88                FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
  89                         "DECLARATION OF REC1" );
  90      END;
  91
  92      BEGIN
  93           DECLARE
  94                TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS
  95                     RECORD
  96                          A : R (P => D);
  97                     END RECORD;
  98
  99           BEGIN
 100                DECLARE
 101                     R2 : REC2;
 102
 103                BEGIN
 104                     R2.A := R'(P => IDENT_INT (1));
 105                     FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " &
 106                              "R2" & INTEGER'IMAGE(R2.A.P));  --USE R2
 107                EXCEPTION
 108                     WHEN OTHERS =>
 109                          FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " &
 110                                   "BLOCK" );
 111                END;
 112
 113           EXCEPTION
 114                WHEN CONSTRAINT_ERROR =>
 115                     NULL;
 116                WHEN OTHERS =>
 117                     FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
 118                              "OF R2" );
 119           END;
 120
 121      EXCEPTION
 122           WHEN CONSTRAINT_ERROR =>
 123                FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
 124                         "DECLARATION OF REC2" );
 125           WHEN OTHERS =>
 126                FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
 127                         "DECLARATION OF REC2" );
 128      END;
 129
 130      BEGIN
 131           DECLARE
 132                PACKAGE PRIV IS
 133                     TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
 134                          PRIVATE;
 135                     PROCEDURE PROC (R :REC3);
 136
 137                PRIVATE
 138                     TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS
 139                          RECORD
 140                               A : R (P => D);
 141                          END RECORD;
 142                END PRIV;
 143
 144                PACKAGE BODY PRIV IS
 145                     PROCEDURE PROC (R : REC3) IS
 146                          I : INTEGER;
 147                     BEGIN
 148                          I := IDENT_INT (R.A.P);
 149                          IF EQUAL(2, IDENT_INT(1)) THEN
 150                               FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I));  --USE I
 151                          END IF;
 152                     END PROC;
 153                END PRIV;
 154
 155                USE PRIV;
 156
 157           BEGIN
 158                DECLARE
 159                     R3 : REC3;
 160
 161                BEGIN
 162                     PROC (R3);
 163                     FAILED ( "NO EXCEPTION RAISED AT " &
 164                               "DECLARATION OF R3" );
 165                EXCEPTION
 166                     WHEN OTHERS =>
 167                          FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " &
 168                                   "BLOCK" );
 169                END;
 170
 171           EXCEPTION
 172                WHEN CONSTRAINT_ERROR =>
 173                     NULL;
 174                WHEN OTHERS =>
 175                     FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
 176                              "OF R3" );
 177           END;
 178
 179      EXCEPTION
 180           WHEN CONSTRAINT_ERROR =>
 181                FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
 182                         "DECLARATION OF REC3" );
 183           WHEN OTHERS =>
 184                FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
 185                         "DECLARATION OF REC3" );
 186      END;
 187
 188      BEGIN
 189           DECLARE
 190                PACKAGE LPRIV IS
 191                     TYPE REC4 (D : NATURAL := IDENT_INT (0))
 192                          IS LIMITED PRIVATE;
 193                     PROCEDURE PROC (R :REC4);
 194
 195                PRIVATE
 196                     TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS
 197                          RECORD
 198                               A : ARR (D .. 5);
 199                          END RECORD;
 200                END LPRIV;
 201
 202                PACKAGE BODY LPRIV IS
 203                     PROCEDURE PROC (R : REC4) IS
 204                          I : INTEGER;
 205                     BEGIN
 206                          I := IDENT_INT (R.A'FIRST);
 207                          IF EQUAL(2, IDENT_INT(1)) THEN
 208                               FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I));  --USE I
 209                          END IF;
 210                     END PROC;
 211                END LPRIV;
 212
 213                USE LPRIV;
 214
 215           BEGIN
 216                DECLARE
 217                     R4 : REC4;
 218
 219                BEGIN
 220                     PROC (R4);
 221                     FAILED ( "NO EXCEPTION RAISED AT " &
 222                              "DECLARATION OF R4" );
 223                EXCEPTION
 224                     WHEN OTHERS =>
 225                          FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " &
 226                                   "BLOCK" );
 227                END;
 228
 229           EXCEPTION
 230                WHEN CONSTRAINT_ERROR =>
 231                     NULL;
 232                WHEN OTHERS =>
 233                     FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " &
 234                              "OF R4" );
 235           END;
 236
 237      EXCEPTION
 238           WHEN CONSTRAINT_ERROR =>
 239                FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " &
 240                         "DECLARATION OF REC4" );
 241           WHEN OTHERS =>
 242                FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " &
 243                         "DECLARATION OF REC4" );
 244      END;
 245
 246      RESULT;
 247 END C37108B;