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

   1 -- C48009B.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 -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR
  26 -- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN
  27 -- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN
  28 -- X:
  29 --   1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING
  30 --      DISCRIMINANT OF T.
  31 --   2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE
  32 --      DECLARATION OF THE ALLOCATOR'S BASE TYPE.
  33 --   3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE
  34 --      BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT
  35 --      CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT.
  36
  37 -- RM  01/08/80
  38 -- NL  10/13/81
  39 -- SPS 10/26/82
  40 -- JBG 03/02/83
  41 -- EG  07/05/84
  42
  43 WITH REPORT;
  44
  45 PROCEDURE  C48009B  IS
  46
  47      USE REPORT;
  48
  49 BEGIN
  50
  51      TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " &
  52                        "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
  53                        "APPROPRIATE - UNCONSTRAINED RECORD AND " &
  54                        "PRIVATE TYPES");
  55
  56      DECLARE
  57
  58           SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7);
  59           SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10);
  60           SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9);
  61
  62           TYPE REC (A : I2_9) IS
  63                RECORD
  64                     NULL;
  65                END RECORD;
  66
  67           TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER;
  68
  69           TYPE T_REC (C : I1_10) IS
  70                RECORD
  71                     D : REC(C);
  72                END RECORD;
  73
  74           TYPE T_ARR (C : I1_10) IS
  75                RECORD
  76                     D : ARR(2..C);
  77                     E : ARR(C..9);
  78                END RECORD;
  79
  80           TYPE T_REC_REC (A : I1_10) IS
  81                RECORD
  82                     B : T_REC(A);
  83                END RECORD;
  84
  85           TYPE T_REC_ARR (A : I1_10) IS
  86                RECORD
  87                     B : T_ARR(A);
  88                END RECORD;
  89
  90           TYPE  TB (  A : I1_7 )  IS
  91                RECORD
  92                     R : INTEGER;
  93                END RECORD;
  94
  95           TYPE A_T_REC_REC IS ACCESS T_REC_REC;
  96           TYPE A_T_REC_ARR IS ACCESS T_REC_ARR;
  97           TYPE ATB IS ACCESS TB;
  98           TYPE ACTB IS ACCESS TB(3);
  99
 100           VA_T_REC_REC : A_T_REC_REC;
 101           VA_T_REC_ARR : A_T_REC_ARR;
 102           VB  : ATB;
 103           VCB : ACTB;
 104
 105           PACKAGE  P  IS
 106                TYPE  PRIV( A : I1_10 )  IS PRIVATE;
 107                CONS_PRIV : CONSTANT PRIV;
 108           PRIVATE
 109                TYPE  PRIV( A : I1_10 )  IS
 110                     RECORD
 111                          R : INTEGER;
 112                     END RECORD;
 113                CONS_PRIV : CONSTANT PRIV := (2, 3);
 114           END P;
 115
 116           USE P;
 117
 118           TYPE  A_PRIV  IS  ACCESS P.PRIV;
 119           TYPE  A_CPRIV IS  ACCESS P.PRIV (3);
 120
 121           VP  : A_PRIV;
 122           VCP : A_CPRIV;
 123
 124           FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS
 125           BEGIN
 126                IF EQUAL(1, 1) THEN
 127                     RETURN NEW P.PRIV'(X);
 128                ELSE
 129                     RETURN NULL;
 130                END IF;
 131           END ALLOC1;
 132           FUNCTION ALLOC2(X : TB) RETURN ACTB IS
 133           BEGIN
 134                IF EQUAL(1, 1) THEN
 135                     RETURN NEW TB'(X);
 136                ELSE
 137                     RETURN NULL;
 138                END IF;
 139           END ALLOC2;
 140
 141      BEGIN
 142
 143           BEGIN     -- B1
 144                VB  :=  NEW TB'(A => IDENT_INT(0), R => 1);
 145                FAILED ("NO EXCEPTION RAISED - CASE 1A");
 146           EXCEPTION
 147                WHEN  CONSTRAINT_ERROR  =>  NULL;
 148                WHEN  OTHERS            =>
 149                     FAILED( "WRONG EXCEPTION RAISED - CASE 1A" );
 150           END;
 151
 152           BEGIN
 153                VB  :=  NEW TB'(A => 8, R => 1);
 154                FAILED ("NO EXCEPTION RAISED - CASE 1B");
 155           EXCEPTION
 156                WHEN  CONSTRAINT_ERROR  =>  NULL;
 157                WHEN  OTHERS            =>
 158                     FAILED( "WRONG EXCEPTION RAISED - CASE 1B");
 159           END; -- B1
 160
 161           BEGIN     -- B2
 162                VCB := NEW TB'(2, 3);
 163                FAILED ("NO EXCEPTION RAISED - CASE 2A");
 164           EXCEPTION
 165                WHEN CONSTRAINT_ERROR => NULL;
 166                WHEN OTHERS =>
 167                     FAILED ("WRONG EXCEPTION RAISED - CASE 2A");
 168           END;
 169
 170           BEGIN
 171                IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN
 172                     FAILED ("IMPOSSIBLE - CASE 2B");
 173                END IF;
 174                FAILED ("NO EXCEPTION RAISED - CASE 2B");
 175           EXCEPTION
 176                WHEN CONSTRAINT_ERROR => NULL;
 177                WHEN OTHERS =>
 178                     FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
 179           END;
 180
 181           BEGIN
 182
 183                IF ALLOC1(CONS_PRIV) = NULL THEN
 184                     FAILED ("IMPOSSIBLE - CASE 2C");
 185                END IF;
 186                FAILED ("NO EXCEPTION RAISED - CASE 2C");
 187
 188           EXCEPTION
 189
 190                WHEN CONSTRAINT_ERROR => NULL;
 191                WHEN OTHERS =>
 192                     FAILED ("WRONG EXCEPTION RAISED - CASE 2C");
 193
 194           END; -- B2
 195
 196           BEGIN     -- B3
 197
 198                VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1)));
 199                FAILED ("NO EXCEPTION RAISED - CASE 3A");
 200
 201           EXCEPTION
 202
 203                WHEN CONSTRAINT_ERROR => NULL;
 204                WHEN OTHERS =>
 205                     FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
 206
 207           END;
 208
 209           BEGIN
 210
 211                VA_T_REC_REC := NEW T_REC_REC'(10,
 212                                              (10, (A => 10)));
 213                FAILED ("NO EXCEPTION RAISED - CASE 3B");
 214
 215           EXCEPTION
 216
 217                WHEN CONSTRAINT_ERROR => NULL;
 218                WHEN OTHERS =>
 219                     FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
 220
 221           END;
 222
 223           BEGIN
 224
 225                VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1),
 226                                                      (OTHERS => 2)));
 227                FAILED ("NO EXCEPTION RAISED - CASE 3C");
 228
 229           EXCEPTION
 230
 231                WHEN CONSTRAINT_ERROR => NULL;
 232                WHEN OTHERS =>
 233                     FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
 234
 235           END;
 236
 237           BEGIN
 238
 239                VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1),
 240                                                        (OTHERS => 2)));
 241                FAILED ("NO EXCEPTION RAISED - CASE 3D");
 242
 243           EXCEPTION
 244
 245                WHEN CONSTRAINT_ERROR => NULL;
 246                WHEN OTHERS =>
 247                     FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
 248
 249           END;
 250
 251      END;
 252
 253      RESULT;
 254
 255 END C48009B;