old-autovect-branch/gcc/testsuite/ada/acats/tests/c6/c64103c.ada

   1 -- C64103C.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 THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS
  26 -- ON IN OUT ARRAY PARAMETERS.  IN PARTICULAR:
  27 --   (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL
  28 --       COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S
  29 --       CONSTRAINTS.
  30 --   (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO
  31 --       AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
  32 --       OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE
  33 --       AI-00313 FOR MULTIDIMENSIONAL CASE)
  34 --   (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A
  35 --       CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER
  36 --       DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL.
  37 --   (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN
  38 --       UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE
  39 --       OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL.
  40
  41 -- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
  42 -- ***       remove incompatibilities associated with the transition   -- 9X
  43 -- ***       to Ada 9X.                                                -- 9X
  44 -- ***                                                                 -- 9X
  45
  46 -- CPP 07/19/84
  47 -- JBG 06/05/85
  48 -- EG  10/29/85  FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO
  49 --               AI-00387.
  50 -- MRM 03/30/93  REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY
  51 -- PWN 01/31/95  REMOVED INCONSISTENCIES WITH ADA 9X.
  52
  53 WITH SYSTEM;
  54 WITH REPORT;  USE REPORT;
  55 PROCEDURE C64103C IS
  56
  57      BEGIN
  58      TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " &
  59            "TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS");
  60
  61      -----------------------------------------------
  62
  63      DECLARE   -- (A)
  64      BEGIN     -- (A)
  65
  66           DECLARE
  67                TYPE SUBINT IS RANGE 0..8;
  68                TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
  69                A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE);
  70
  71                PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS
  72                BEGIN
  73                     NULL;
  74                END P2;
  75           BEGIN
  76                P2 (ARRAY_TYPE (A0));                  -- OK.
  77           EXCEPTION
  78                WHEN OTHERS =>
  79                     FAILED ("EXCEPTION RAISED -P2 (A)");
  80           END;
  81
  82      END; -- (A)
  83
  84      -----------------------------------------------
  85
  86      DECLARE   -- (B1) NON-NULL ACTUAL PARAMETER
  87
  88           TYPE SUBINT IS RANGE 0..8;
  89           TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN;
  90           TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN;
  91           A1 : AR1 (-1..7) := (-1..7 => TRUE);
  92           A2 : AR1 (1..9) := (1..9 => TRUE);
  93
  94           PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
  95           BEGIN
  96                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
  97           END P1;
  98
  99      BEGIN     -- (B1)
 100
 101           BEGIN
 102                COMMENT ("CALL TO P1 (B1) ON A1");
 103                P1 (ARRAY_TYPE (A1));
 104           EXCEPTION
 105                WHEN CONSTRAINT_ERROR =>
 106                     NULL;
 107                WHEN OTHERS =>
 108                     FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
 109           END;
 110
 111           BEGIN
 112                COMMENT ("CALL TO P1 (B1) ON A2");
 113                P1 (ARRAY_TYPE (A2));
 114           EXCEPTION
 115                WHEN CONSTRAINT_ERROR =>
 116                     NULL;
 117                WHEN OTHERS =>
 118                     FAILED ("WRONG EXCEPTION RAISED -P1 (B1)");
 119           END;
 120
 121      END; -- (B1)
 122
 123      DECLARE   -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL
 124
 125           TYPE SUBINT IS RANGE 0..8;
 126           TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>,
 127                                     SUBINT RANGE <>) OF BOOLEAN;
 128           TYPE AR1 IS ARRAY (INTEGER RANGE <>,
 129                              INTEGER RANGE <>)OF BOOLEAN;
 130           A1 : AR1 (IDENT_INT(-1)..7, 5..4) :=
 131                                            (OTHERS => (OTHERS => TRUE));
 132           A2 : AR1 (5..4, 1..IDENT_INT(9)) :=
 133                                            (OTHERS => (OTHERS => TRUE));
 134           PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
 135           BEGIN
 136                FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)");
 137           END P1;
 138
 139      BEGIN     -- (B2)
 140
 141           BEGIN
 142                COMMENT ("CALL TO P1 (B2) ON A1");
 143                P1 (ARRAY_TYPE (A1));
 144           EXCEPTION
 145                WHEN CONSTRAINT_ERROR =>
 146                     NULL;
 147                WHEN OTHERS =>
 148                     FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
 149           END;
 150
 151           BEGIN
 152                COMMENT ("CALL TO P1 (B2) ON A2");
 153                P1 (ARRAY_TYPE (A2));
 154           EXCEPTION
 155                WHEN CONSTRAINT_ERROR =>
 156                     NULL;
 157                WHEN OTHERS =>
 158                     FAILED ("WRONG EXCEPTION RAISED -P1 (B2)");
 159           END;
 160
 161      END; -- (B2)
 162
 163      -----------------------------------------------
 164
 165      BEGIN     -- (C)
 166
 167           DECLARE
 168                TYPE INDEX1 IS RANGE 1..3;
 169                TYPE INDEX2 IS RANGE 1..4;
 170                TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN;
 171                A0 : AR_TYPE := (1..3 => (1..4 => FALSE));
 172
 173                TYPE I1 IS RANGE 1..4;
 174                TYPE I2 IS RANGE 1..3;
 175                TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN;
 176
 177                PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS
 178                BEGIN
 179                     FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)");
 180                END P1;
 181           BEGIN
 182                P1 (ARRAY_TYPE (A0));
 183           EXCEPTION
 184                WHEN CONSTRAINT_ERROR =>
 185                     NULL;
 186                WHEN OTHERS =>
 187                     FAILED ("WRONG EXCEPTION RAISED -P1 (C)");
 188           END;
 189
 190      END; -- (C)
 191
 192      -----------------------------------------------
 193
 194      DECLARE   -- (D)
 195      BEGIN     -- (D)
 196
 197           DECLARE
 198                TYPE SM_INT IS RANGE 0..2;
 199                TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT;
 200                SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 ..
 201                                           SYSTEM.MAX_INT;
 202                TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN;
 203                TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN;
 204                A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) :=
 205                     (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE);
 206
 207                PROCEDURE P1 (X : IN OUT AR_SMALL) IS
 208                BEGIN
 209                     FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)");
 210                END P1;
 211           BEGIN
 212                IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN
 213                     P1 (AR_SMALL (A0));
 214                ELSE
 215                     COMMENT ("NOT APPLICABLE -P1 (D)");
 216                END IF;
 217           EXCEPTION
 218                WHEN CONSTRAINT_ERROR =>
 219                     COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)");
 220                WHEN OTHERS =>
 221                     FAILED ("WRONG EXCEPTION RAISED - P1 (D)");
 222           END;
 223
 224      END; -- (D)
 225
 226      -----------------------------------------------
 227
 228      RESULT;
 229
 230 END C64103C;