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

   1 -- C48009E.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 A CONSTRAINED ARRAY TYPE AND:
  27 --   1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE
  28 --      CORRESPONDING BOUND FOR T;
  29 --   2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN
  30 --      THE DECLARATION OF THE ALLOCATOR'S BASE TYPE;
  31 --   3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS
  32 --      REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE.
  33
  34  -- RM  01/08/80
  35  -- NL  10/13/81
  36  -- SPS 10/26/82
  37  -- JBG 03/03/83
  38  -- EG  07/05/84
  39  -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
  40  -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE
  41  -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS
  42  -- PWN 05/03/96 Enforced Ada 95 sliding rules
  43  -- PWN 10/24/96 Adjusted expected results for Ada 95.
  44  -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES
  45  -- MRM 12/16/96 Removed problem code from withdrawn version of test, and
  46  --              implemented a dereference-index check to ensure Ada95
  47  --              required behavior.
  48  -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does
  49  --                  not occur
  50  WITH REPORT;
  51
  52  PROCEDURE  C48009E  IS
  53
  54       USE REPORT ;
  55
  56  BEGIN
  57
  58       TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
  59                      "THAT CONSTRAINT_ERROR IS RAISED WHEN "          &
  60                      "APPROPRIATE - CONSTRAINED ARRAY TYPES");
  61       DECLARE
  62
  63            TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER;
  64            TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER;
  65            TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER;
  66            TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER;
  67            SUBTYPE CA2_6 IS UA(2 .. 6);
  68            SUBTYPE CA1_4 IS UA(1 .. 4);
  69            SUBTYPE CA1_6 IS UA(1 .. 6);
  70            SUBTYPE CA4_1 IS UA(4 .. 1);
  71            SUBTYPE CA4_2 IS UA(4 .. 2);
  72
  73            TYPE A_CA3_2 IS ACCESS CA3_2;
  74            TYPE A_SA1_3 IS ACCESS SA1_3;
  75            TYPE A_NA1_3 IS ACCESS NA1_3;
  76            TYPE A_CA1_5 IS ACCESS UA(1 .. 5);
  77            TYPE A_CA4_2 IS ACCESS CA4_2;
  78
  79            V_A_CA3_2 : A_CA3_2;
  80            V_A_SA1_3 : A_SA1_3;
  81            V_A_NA1_3 : A_NA1_3;
  82            V_A_CA1_5 : A_CA1_5;
  83
  84            FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS
  85            BEGIN
  86                 IF EQUAL(1, 1) THEN
  87                      RETURN NEW CA2_6'(X);
  88                 ELSE
  89                      RETURN NULL;
  90                 END IF;
  91            END ALLOC1;
  92            FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS
  93            BEGIN
  94                 IF EQUAL(1, 1) THEN
  95                      RETURN NEW CA4_1'(X);
  96                 ELSE
  97                      RETURN NULL;
  98                 END IF;
  99            END ALLOC2;
 100
 101       BEGIN
 102
 103           BEGIN
 104                V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2)
 105                                        => 5);
 106                FAILED ("NO EXCEPTION RAISED - CASE 1A");
 107           EXCEPTION
 108                WHEN CONSTRAINT_ERROR =>
 109                     NULL;
 110                WHEN OTHERS =>
 111                     FAILED ("WRONG EXCEPTION RAISED - CASE 1A");
 112           END;
 113
 114            BEGIN
 115                 V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4);
 116                 FAILED ("NO EXCEPTION RAISED - CASE 1B");
 117            EXCEPTION
 118                 WHEN CONSTRAINT_ERROR =>
 119                      NULL;
 120                 WHEN OTHERS =>
 121                      FAILED ("WRONG EXCEPTION RAISED - CASE 1B");
 122            END;
 123
 124            BEGIN
 125                 -- note that ALLOC1 returns A_CA1_5, so both
 126                 -- (1) and (5) are valid index references!
 127                 IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN
 128                      FAILED ("Wrong Value Returned - CASE 2A");
 129                 ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN
 130                      FAILED ("Unlikely Index Case - CASE 2A");
 131                 END IF;
 132            EXCEPTION
 133                 WHEN OTHERS =>
 134                      FAILED ("EXCEPTION RAISED - CASE 2A");
 135            END;
 136
 137            BEGIN
 138                 IF ALLOC2((4 .. 1 => 3)) = NULL THEN
 139                      FAILED ("IMPOSSIBLE - CASE 2B");
 140                 END IF;
 141                 COMMENT ("ADA 95 SLIDING ASSIGNMENT");
 142            EXCEPTION
 143                 WHEN CONSTRAINT_ERROR =>
 144                      FAILED ("ADA 83 NON-SLIDING ASSIGNMENT");
 145                 WHEN OTHERS =>
 146                      FAILED ("WRONG EXCEPTION RAISED - CASE 2B");
 147            END;
 148
 149            BEGIN
 150                 V_A_SA1_3 := NEW SA1_3'(1, 2);
 151                 FAILED ("NO EXCEPTION RAISED - CASE 3A");
 152            EXCEPTION
 153                 WHEN CONSTRAINT_ERROR =>
 154                      NULL;
 155                 WHEN OTHERS =>
 156                      FAILED ("WRONG EXCEPTION RAISED - CASE 3A");
 157            END;
 158
 159            BEGIN
 160                 V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6);
 161                 FAILED ("NO EXCEPTION RAISED - CASE 3B");
 162            EXCEPTION
 163                 WHEN CONSTRAINT_ERROR =>
 164                      NULL;
 165                 WHEN OTHERS =>
 166                      FAILED ("WRONG EXCEPTION RAISED - CASE 3B");
 167            END;
 168
 169            BEGIN
 170                 V_A_NA1_3 := NEW NA1_3'(1, 2);
 171                 FAILED ("NO EXCEPTION RAISED - CASE 3C");
 172            EXCEPTION
 173                 WHEN CONSTRAINT_ERROR =>
 174                      NULL;
 175                 WHEN OTHERS =>
 176                      FAILED ("WRONG EXCEPTION RAISED - CASE 3C");
 177            END;
 178
 179            BEGIN -- SATISFIES T BUT NOT BASE TYPE.
 180                 V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4);
 181                 FAILED ("NO EXCEPTION RAISED - CASE 3D");
 182            EXCEPTION
 183                 WHEN CONSTRAINT_ERROR =>
 184                      NULL;
 185                 WHEN OTHERS =>
 186                      FAILED ("WRONG EXCEPTION RAISED - CASE 3D");
 187            END;
 188
 189            BEGIN -- SATISFIES T BUT NOT BASE TYPE.
 190                 V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6);
 191                 FAILED ("NO EXCEPTION RAISED - CASE 3E");
 192            EXCEPTION
 193                 WHEN CONSTRAINT_ERROR =>
 194                      NULL;
 195                 WHEN OTHERS =>
 196                      FAILED ("WRONG EXCEPTION RAISED - CASE 3E");
 197            END;
 198
 199            BEGIN -- SATISFIES BASE TYPE BUT NOT T.
 200                 V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5);
 201                 FAILED ("NO EXCEPTION RAISED - CASE 3F");
 202            EXCEPTION
 203                 WHEN CONSTRAINT_ERROR =>
 204                      NULL;
 205                 WHEN OTHERS =>
 206                      FAILED ("WRONG EXCEPTION RAISED - CASE 3F");
 207            END;
 208
 209           BEGIN -- SATISFIES BASE TYPE BUT NOT T.
 210                V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5);
 211                FAILED ("NO EXCEPTION RAISED - CASE 3G");
 212           EXCEPTION
 213                WHEN CONSTRAINT_ERROR =>
 214                     NULL;
 215                WHEN OTHERS =>
 216                     FAILED ("WRONG EXCEPTION RAISED - CASE 3G");
 217           END;
 218
 219       END ;
 220
 221       RESULT ;
 222
 223  END C48009E ;
 224