old-autovect-branch/gcc/testsuite/ada/acats/tests/c9/c95086b.ada

   1 -- C95086B.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 --   BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS
  27 --   PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT
  28 --   FROM THE FORMAL PARAMETER.
  29 --
  30 --   SUBTESTS ARE:
  31 --       (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS.
  32 --       (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS.
  33 --       (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
  34 --       (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION.
  35
  36 -- RJW 1/27/86
  37
  38 WITH REPORT; USE REPORT;
  39 PROCEDURE C95086B IS
  40
  41 BEGIN
  42      TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " &
  43             "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " &
  44             "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " &
  45             "DIFFERENT FROM THE FORMAL PARAMETER" );
  46
  47      --------------------------------------------------
  48
  49      DECLARE -- (A)
  50
  51           TYPE E IS (E1, E2, E3, E4);
  52           TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
  53
  54           TYPE A IS ACCESS T;
  55           SUBTYPE SA IS A (E2..E4);
  56           V : A (E1..E2) := NULL;
  57
  58           TASK T1 IS
  59                ENTRY P (X : SA);
  60           END T1;
  61
  62           TASK BODY T1 IS
  63           BEGIN
  64                ACCEPT P (X : SA);
  65           EXCEPTION
  66                WHEN OTHERS =>
  67                     FAILED ( "EXCEPTION RAISED IN TASK - (A)" );
  68           END T1;
  69
  70      BEGIN -- (A)
  71
  72           T1.P (V);
  73
  74      EXCEPTION
  75           WHEN OTHERS =>
  76                FAILED ( "EXCEPTION RAISED - (A)" );
  77      END; -- (A)
  78
  79      --------------------------------------------------
  80
  81      DECLARE -- (B)
  82
  83           TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
  84
  85           TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
  86                RECORD
  87                     I : INTEGER;
  88                     CASE B IS
  89                          WHEN FALSE =>
  90                               J : INTEGER;
  91                          WHEN TRUE =>
  92                               A : ARR ('A' .. C);
  93                     END CASE;
  94                END RECORD;
  95
  96           TYPE A IS ACCESS T;
  97           SUBTYPE SA IS A (TRUE, 'C');
  98           V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
  99
 100           TASK T1 IS
 101                ENTRY P (X : IN OUT SA);
 102           END T1;
 103
 104           TASK BODY T1 IS
 105           BEGIN
 106                ACCEPT P (X : IN OUT SA) DO
 107                     NULL;
 108                END P;
 109           EXCEPTION
 110                WHEN OTHERS =>
 111                     FAILED ( "EXCEPTION RAISED IN TASK - (B)" );
 112           END T1;
 113
 114      BEGIN -- (B)
 115
 116           T1.P (V);
 117
 118      EXCEPTION
 119           WHEN OTHERS =>
 120                FAILED ( "EXCEPTION RAISED - (B)" );
 121      END; -- (B)
 122
 123      --------------------------------------------------
 124
 125      DECLARE -- (C)
 126
 127           TYPE E IS (E1, E2, E3, E4);
 128           TYPE T IS ARRAY (E RANGE <>) OF INTEGER;
 129
 130           TYPE A IS ACCESS T;
 131           SUBTYPE SA IS A (E2..E4);
 132           V : A (E1..E2) := NULL;
 133
 134           TASK T1 IS
 135                ENTRY P (X : SA);
 136           END T1;
 137
 138           TASK BODY T1 IS
 139           BEGIN
 140                ACCEPT P (X : SA) DO
 141                     NULL;
 142                END P;
 143           EXCEPTION
 144                WHEN OTHERS =>
 145                     FAILED ( "EXCEPTION RAISED IN TASK - (C)" );
 146           END T1;
 147
 148      BEGIN -- (C)
 149
 150           T1.P (SA(V));
 151
 152      EXCEPTION
 153           WHEN OTHERS =>
 154                FAILED ( "EXCEPTION RAISED - (C)" );
 155      END; -- (C)
 156
 157      --------------------------------------------------
 158
 159      DECLARE -- (D)
 160
 161           TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER;
 162
 163           TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS
 164                RECORD
 165                     I : INTEGER;
 166                     CASE B IS
 167                          WHEN FALSE =>
 168                               J : INTEGER;
 169                          WHEN TRUE =>
 170                               A : ARR ('A' .. C);
 171                     END CASE;
 172                END RECORD;
 173
 174           TYPE A IS ACCESS T;
 175           SUBTYPE SA IS A (TRUE, 'C');
 176           V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL;
 177
 178           TASK T1 IS
 179                ENTRY P (X : IN OUT SA);
 180           END T1;
 181
 182           TASK BODY T1 IS
 183           BEGIN
 184                ACCEPT P (X : IN OUT SA);
 185           EXCEPTION
 186                WHEN OTHERS =>
 187                     FAILED ( "EXCEPTION RAISED IN TASK - (D)" );
 188           END T1;
 189
 190      BEGIN -- (D)
 191
 192           T1.P (SA(V));
 193
 194      EXCEPTION
 195           WHEN OTHERS =>
 196                FAILED ( "EXCEPTION RAISED - (D)" );
 197      END; -- (D)
 198
 199      --------------------------------------------------
 200
 201      RESULT;
 202 END C95086B;