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

   1 -- C64104C.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 UNDER THE
  26 --   APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS, NAMELY
  27 --   WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS
  28 --   (BEFORE THE CALL FOR ALL MODES).
  29 --   SUBTESTS ARE:
  30 --      (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE.
  31 --      (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE.
  32 --      (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE.
  33 --      (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE.
  34 --      (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE.
  35 --      (F) IN OUT MODE, NULL STRING AGGREGATE.
  36 --      (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE).
  37 --          IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE.
  38
  39 -- JRK 3/17/81
  40 -- SPS 10/26/82
  41 -- CPP 8/6/84
  42 -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
  43
  44 WITH REPORT;
  45 PROCEDURE C64104C IS
  46
  47      USE REPORT;
  48
  49 BEGIN
  50      TEST ("C64104C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
  51            "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
  52
  53      --------------------------------------------------
  54
  55      DECLARE -- (A)
  56           SUBTYPE ST IS STRING (1..3);
  57
  58           PROCEDURE P (A : ST) IS
  59           BEGIN
  60                FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
  61           EXCEPTION
  62                WHEN OTHERS =>
  63                     FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)");
  64           END P;
  65
  66      BEGIN -- (A)
  67
  68           P ("AB");
  69           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");
  70
  71      EXCEPTION
  72           WHEN CONSTRAINT_ERROR =>
  73                NULL;
  74           WHEN OTHERS =>
  75                FAILED ("WRONG EXCEPTION RAISED - (A)");
  76      END; -- (A)
  77
  78      --------------------------------------------------
  79
  80      DECLARE -- (B)
  81
  82           SUBTYPE S IS INTEGER RANGE 1..3;
  83           TYPE T IS ARRAY (S,S) OF INTEGER;
  84
  85           PROCEDURE P (A : T) IS
  86           BEGIN
  87                FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
  88           EXCEPTION
  89                WHEN OTHERS =>
  90                     FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)");
  91           END P;
  92
  93      BEGIN -- (B)
  94
  95           P ((1..3 => (1..IDENT_INT(2) => 0)));
  96           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");
  97
  98      EXCEPTION
  99           WHEN CONSTRAINT_ERROR =>
 100                NULL;
 101           WHEN OTHERS =>
 102                FAILED ("WRONG EXCEPTION RAISED - (B)");
 103      END; -- (B)
 104
 105      --------------------------------------------------
 106
 107      DECLARE -- (C)
 108
 109           SUBTYPE S IS INTEGER RANGE 1..5;
 110           TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
 111           SUBTYPE ST IS T (1..3,1..3);
 112           V : T (1..IDENT_INT(2), 1..3) :=
 113                 (1..IDENT_INT(2) => (1..3 => 0));
 114
 115           PROCEDURE P (A :ST) IS
 116           BEGIN
 117                FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
 118           EXCEPTION
 119                WHEN OTHERS =>
 120                     FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)");
 121           END P;
 122
 123      BEGIN -- (C)
 124
 125           P (V);
 126           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");
 127
 128      EXCEPTION
 129           WHEN CONSTRAINT_ERROR =>
 130                NULL;
 131           WHEN OTHERS =>
 132                FAILED ("WRONG EXCEPTION RAISED - (C)");
 133      END; -- (C)
 134
 135      --------------------------------------------------
 136
 137      DECLARE -- (D)
 138
 139           SUBTYPE S IS INTEGER RANGE 1..5;
 140           TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
 141                     INTEGER;
 142           SUBTYPE ST IS T (1..3, 1..3, 1..3);
 143           V : T (1..3, 1..2, 1..3) :=
 144                 (1..3 => (1..2 => (1..3 => 0)));
 145
 146           PROCEDURE P (A : IN OUT ST) IS
 147           BEGIN
 148                FAILED ("EXCEPTION NOT RAISED ON CALLL - (D)");
 149           EXCEPTION
 150                WHEN OTHERS =>
 151                     FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)");
 152           END P;
 153
 154      BEGIN -- (D)
 155
 156           P (V);
 157           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");
 158
 159      EXCEPTION
 160           WHEN CONSTRAINT_ERROR =>
 161                NULL;
 162           WHEN OTHERS =>
 163                FAILED ("WRONG EXCEPTION RAISED - (D)");
 164      END; -- (D)
 165
 166      --------------------------------------------------
 167
 168
 169      DECLARE -- (G)
 170
 171           SUBTYPE S IS INTEGER RANGE 1..5;
 172           TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
 173           SUBTYPE ST IS T (2..1, 2..1);
 174           V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));
 175
 176           PROCEDURE P (A : IN OUT ST) IS
 177           BEGIN
 178                COMMENT ("OK CASE CALLED CORRECTLY");
 179           EXCEPTION
 180                WHEN OTHERS =>
 181                     FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)");
 182           END P;
 183
 184      BEGIN -- (G)
 185
 186           P (V);
 187
 188      EXCEPTION
 189           WHEN CONSTRAINT_ERROR =>
 190                FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
 191           WHEN OTHERS =>
 192                FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
 193      END; -- (G)
 194
 195      --------------------------------------------------
 196
 197      --------------------------------------------------
 198
 199      RESULT;
 200 END C64104C;