gcc/testsuite/ada/acats/tests/c6/c64103d.ada

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