gomp-20050608-branch/gcc/testsuite/ada/acats/tests/c9/c95085c.ada

   1 -- C95085C.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 IN ENTRY CALLS,
  27 -- NAMELY 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 -- JWC 10/28/85
  40 -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X.
  41
  42 WITH REPORT; USE REPORT;
  43 PROCEDURE C95085C IS
  44
  45 BEGIN
  46      TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " &
  47                       "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS");
  48
  49      --------------------------------------------------
  50
  51      DECLARE -- (A)
  52           SUBTYPE ST IS STRING (1..3);
  53
  54           TASK TSK IS
  55                ENTRY E (A : ST);
  56           END TSK;
  57
  58           TASK BODY TSK IS
  59           BEGIN
  60                SELECT
  61                     ACCEPT E (A : ST) DO
  62                          FAILED ("EXCEPTION NOT RAISED ON CALL - (A)");
  63                     END E;
  64                OR
  65                     TERMINATE;
  66                END SELECT;
  67           EXCEPTION
  68                WHEN OTHERS =>
  69                     FAILED ("EXCEPTION RAISED IN TASK - (A)");
  70           END TSK;
  71
  72      BEGIN -- (A)
  73
  74           TSK.E ("AB");
  75           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)");
  76
  77      EXCEPTION
  78           WHEN CONSTRAINT_ERROR =>
  79                NULL;
  80           WHEN OTHERS =>
  81                FAILED ("WRONG EXCEPTION RAISED - (A)");
  82      END; -- (A)
  83
  84      --------------------------------------------------
  85
  86      DECLARE -- (B)
  87
  88           SUBTYPE S IS INTEGER RANGE 1..3;
  89           TYPE T IS ARRAY (S,S) OF INTEGER;
  90
  91           TASK TSK IS
  92                ENTRY E (A : T);
  93           END TSK;
  94
  95           TASK BODY TSK IS
  96           BEGIN
  97                SELECT
  98                     ACCEPT E (A : T) DO
  99                          FAILED ("EXCEPTION NOT RAISED ON CALL - (B)");
 100                     END E;
 101                OR
 102                     TERMINATE;
 103                END SELECT;
 104           EXCEPTION
 105                WHEN OTHERS =>
 106                     FAILED ("EXCEPTION RAISED IN TASK - (B)");
 107           END TSK;
 108
 109      BEGIN -- (B)
 110
 111           TSK.E ((1..3 => (1..IDENT_INT(2) => 0)));
 112           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)");
 113
 114      EXCEPTION
 115           WHEN CONSTRAINT_ERROR =>
 116                NULL;
 117           WHEN OTHERS =>
 118                FAILED ("WRONG EXCEPTION RAISED - (B)");
 119      END; -- (B)
 120
 121      --------------------------------------------------
 122
 123      DECLARE -- (C)
 124
 125           SUBTYPE S IS INTEGER RANGE 1..5;
 126           TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER;
 127           SUBTYPE ST IS T (1..3,1..3);
 128           V : T (1..IDENT_INT(2), 1..3) :=
 129                 (1..IDENT_INT(2) => (1..3 => 0));
 130
 131           TASK TSK IS
 132                ENTRY E (A :ST);
 133           END TSK;
 134
 135           TASK BODY TSK IS
 136           BEGIN
 137                SELECT
 138                     ACCEPT E (A :ST) DO
 139                          FAILED ("EXCEPTION NOT RAISED ON CALL - (C)");
 140                     END E;
 141                OR
 142                     TERMINATE;
 143                END SELECT;
 144           EXCEPTION
 145                WHEN OTHERS =>
 146                     FAILED ("EXCEPTION RAISED IN TASK - (C)");
 147           END TSK;
 148
 149      BEGIN -- (C)
 150
 151           TSK.E (V);
 152           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)");
 153
 154      EXCEPTION
 155           WHEN CONSTRAINT_ERROR =>
 156                NULL;
 157           WHEN OTHERS =>
 158                FAILED ("WRONG EXCEPTION RAISED - (C)");
 159      END; -- (C)
 160
 161      --------------------------------------------------
 162
 163      DECLARE -- (D)
 164
 165           SUBTYPE S IS INTEGER RANGE 1..5;
 166           TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF
 167                     INTEGER;
 168           SUBTYPE ST IS T (1..3, 1..3, 1..3);
 169           V : T (1..3, 1..2, 1..3) :=
 170                 (1..3 => (1..2 => (1..3 => 0)));
 171
 172           TASK TSK IS
 173                ENTRY E (A : IN OUT ST);
 174           END TSK;
 175
 176           TASK BODY TSK IS
 177           BEGIN
 178                SELECT
 179                     ACCEPT E (A : IN OUT ST) DO
 180                          FAILED ("EXCEPTION NOT RAISED ON CALL - (D)");
 181                     END E;
 182                OR
 183                     TERMINATE;
 184                END SELECT;
 185           EXCEPTION
 186                WHEN OTHERS =>
 187                     FAILED ("EXCEPTION RAISED IN TASK - (D)");
 188           END TSK;
 189
 190      BEGIN -- (D)
 191
 192           TSK.E (V);
 193           FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)");
 194
 195      EXCEPTION
 196           WHEN CONSTRAINT_ERROR =>
 197                NULL;
 198           WHEN OTHERS =>
 199                FAILED ("WRONG EXCEPTION RAISED - (D)");
 200      END; -- (D)
 201
 202      --------------------------------------------------
 203
 204
 205      DECLARE -- (G)
 206
 207           SUBTYPE S IS INTEGER RANGE 1..5;
 208           TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER;
 209           SUBTYPE ST IS T (2..1, 2..1);
 210           V : T (2..1, 2..1) := (2..1 => (2..1 => ' '));
 211
 212           TASK TSK IS
 213                ENTRY E (A : IN OUT ST);
 214           END TSK;
 215
 216           TASK BODY TSK IS
 217           BEGIN
 218                SELECT
 219                     ACCEPT E (A : IN OUT ST)  DO
 220                          COMMENT ("OK CASE CALLED CORRECTLY");
 221                     END E;
 222                OR
 223                     TERMINATE;
 224                END SELECT;
 225           EXCEPTION
 226                WHEN OTHERS =>
 227                     FAILED ("EXCEPTION RAISED IN TASK - (G)");
 228           END TSK;
 229
 230      BEGIN -- (G)
 231
 232           TSK.E (V);
 233
 234      EXCEPTION
 235           WHEN CONSTRAINT_ERROR =>
 236                FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)");
 237           WHEN OTHERS =>
 238                FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)");
 239      END; -- (G)
 240
 241      --------------------------------------------------
 242
 243
 244      RESULT;
 245 END C95085C;