gcc/testsuite/ada/acats/tests/c9/c95086c.ada

   1 -- C95086C.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 NOT RAISED FOR ACCESS PARAMETERS
  26 --   AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL
  27 --   ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS
  28 --   DIFFERENT CONSTRAINTS.
  29 --
  30 --   SUBTESTS ARE:
  31 --       (A) IN OUT MODE, STATIC PRIVATE DISCRIMINANT.
  32 --       (B) OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS.
  33 --       (C) SAME AS (A), WITH TYPE CONVERSION.
  34 --       (D) SAME AS (B), WITH TYPE CONVERSION.
  35
  36 -- RJW 1/29/86
  37
  38 WITH REPORT; USE REPORT;
  39 PROCEDURE C95086C IS
  40
  41 BEGIN
  42      TEST ("C95086C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
  43            "AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL " &
  44            "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " &
  45            "DIFFERENT CONSTRAINTS" );
  46
  47      --------------------------------------------------
  48
  49      DECLARE -- (A)
  50
  51           PACKAGE PKG IS
  52                TYPE E IS (E1, E2);
  53                TYPE T (D : E := E1) IS PRIVATE;
  54           PRIVATE
  55                TYPE T (D : E := E1) IS
  56                     RECORD
  57                          I : INTEGER;
  58                          CASE D IS
  59                               WHEN E1 =>
  60                                    B : BOOLEAN;
  61                               WHEN E2 =>
  62                                    C : CHARACTER;
  63                          END CASE;
  64                     END RECORD;
  65           END PKG;
  66
  67           USE PKG;
  68
  69           TYPE A IS ACCESS T;
  70           SUBTYPE SA IS A (E2);
  71           V : A (E1) := NULL;
  72           ENTERED : BOOLEAN := FALSE;
  73
  74           TASK T1 IS
  75                ENTRY P (X : IN OUT SA);
  76           END T1;
  77
  78           TASK BODY T1 IS
  79           BEGIN
  80                ACCEPT P (X : IN OUT SA) DO
  81                     ENTERED := TRUE;
  82                     X := NULL;
  83                END P;
  84           EXCEPTION
  85                WHEN OTHERS =>
  86                     FAILED ("EXCEPTION RAISED IN TASK - (A)");
  87           END T1;
  88
  89      BEGIN -- (A)
  90
  91           T1.P (V);
  92
  93      EXCEPTION
  94           WHEN CONSTRAINT_ERROR =>
  95                IF NOT ENTERED THEN
  96                     FAILED ("EXCEPTION RAISED BEFORE CALL - (A)");
  97                ELSE
  98                     FAILED ("EXCEPTION RAISED ON RETURN - (A)");
  99                END IF;
 100           WHEN OTHERS =>
 101                FAILED ("EXCEPTION RAISED - (A)");
 102      END; -- (A)
 103
 104      --------------------------------------------------
 105
 106      DECLARE -- (B)
 107
 108           TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
 109                     INTEGER;
 110
 111           TYPE A IS ACCESS T;
 112           SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
 113           V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
 114                  IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
 115           ENTERED : BOOLEAN := FALSE;
 116
 117           TASK T1 IS
 118                ENTRY P (X : OUT SA);
 119           END T1;
 120
 121           TASK BODY T1 IS
 122           BEGIN
 123                ACCEPT P (X : OUT SA) DO
 124                     ENTERED := TRUE;
 125                     X := NULL;
 126                END P;
 127           EXCEPTION
 128                WHEN OTHERS =>
 129                     FAILED ("EXCEPTION RAISED IN TASK - (B)");
 130           END T1;
 131
 132      BEGIN -- (B)
 133
 134           T1.P (V);
 135
 136      EXCEPTION
 137           WHEN CONSTRAINT_ERROR =>
 138                IF NOT ENTERED THEN
 139                     FAILED ("EXCEPTION RAISED BEFORE CALL - (B)");
 140                ELSE
 141                     FAILED ("EXCEPTION RAISED ON RETURN - (B)");
 142                END IF;
 143           WHEN OTHERS =>
 144                FAILED ("EXCEPTION RAISED - (B)");
 145      END; -- (B)
 146
 147      --------------------------------------------------
 148
 149      DECLARE -- (C)
 150
 151           PACKAGE PKG IS
 152                TYPE E IS (E1, E2);
 153                TYPE T (D : E := E1) IS PRIVATE;
 154           PRIVATE
 155                TYPE T (D : E := E1) IS
 156                     RECORD
 157                          I : INTEGER;
 158                          CASE D IS
 159                               WHEN E1 =>
 160                                    B : BOOLEAN;
 161                               WHEN E2 =>
 162                                    C : CHARACTER;
 163                          END CASE;
 164                     END RECORD;
 165           END PKG;
 166
 167           USE PKG;
 168
 169           TYPE A IS ACCESS T;
 170           SUBTYPE SA IS A (E2);
 171           V : A (E1) := NULL;
 172           ENTERED : BOOLEAN := FALSE;
 173
 174           TASK T1 IS
 175                ENTRY P (X : IN OUT SA);
 176           END T1;
 177
 178           TASK BODY T1 IS
 179           BEGIN
 180                ACCEPT P (X : IN OUT SA) DO
 181                     ENTERED := TRUE;
 182                     X := NULL;
 183                END P;
 184           EXCEPTION
 185                WHEN OTHERS =>
 186                     FAILED ("EXCEPTION RAISED IN TASK - (C)");
 187           END T1;
 188
 189      BEGIN -- (C)
 190
 191           T1.P (SA(V));
 192
 193      EXCEPTION
 194           WHEN CONSTRAINT_ERROR =>
 195                IF NOT ENTERED THEN
 196                     FAILED ("EXCEPTION RAISED BEFORE CALL - (C)");
 197                ELSE
 198                     FAILED ("EXCEPTION RAISED ON RETURN - (C)");
 199                END IF;
 200           WHEN OTHERS =>
 201                FAILED ("EXCEPTION RAISED - (C)");
 202      END; -- (C)
 203
 204      --------------------------------------------------
 205
 206      DECLARE -- (D)
 207
 208           TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF
 209                     INTEGER;
 210
 211           TYPE A IS ACCESS T;
 212           SUBTYPE SA IS A ('D'..'F', FALSE..FALSE);
 213           V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'),
 214                  IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL;
 215           ENTERED : BOOLEAN := FALSE;
 216
 217           TASK T1 IS
 218                ENTRY P (X : OUT SA);
 219           END T1;
 220
 221           TASK BODY T1 IS
 222           BEGIN
 223                ACCEPT P (X : OUT SA) DO
 224                     ENTERED := TRUE;
 225                     X := NULL;
 226                END P;
 227           EXCEPTION
 228                WHEN OTHERS =>
 229                     FAILED ("EXCEPTION RAISED IN TASK - (D)");
 230           END T1;
 231
 232      BEGIN -- (D)
 233
 234           T1.P (SA(V));
 235
 236      EXCEPTION
 237           WHEN CONSTRAINT_ERROR =>
 238                IF NOT ENTERED THEN
 239                     FAILED ("EXCEPTION RAISED BEFORE CALL - (D)");
 240                ELSE
 241                     FAILED ("EXCEPTION RAISED ON RETURN - (D)");
 242                END IF;
 243           WHEN OTHERS =>
 244                FAILED ("EXCEPTION RAISED - (D)");
 245      END; -- (D)
 246
 247      --------------------------------------------------
 248
 249      RESULT;
 250 END C95086C;