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

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