gcc/testsuite/ada/acats/tests/c4/c43207b.ada

   1 -- C43207B.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 -- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)),
  26 -- CHECK THAT:
  27
  28 --     B) IF H..I IS A NULL RANGE, CONSTRAINT_ERROR IS RAISED IF
  29 --        F..G IS NON-NULL AND F OR G DO NOT BELONG TO THE INDEX
  30 --        SUBTYPE;
  31
  32 -- EG  01/18/84
  33 -- BHS  7/13/84
  34 -- JBG 12/6/84
  35
  36 WITH REPORT;
  37
  38 PROCEDURE C43207B IS
  39
  40      USE REPORT;
  41
  42 BEGIN
  43
  44      TEST("C43207B", "CHECK THAT THE EVALUATION OF A MULTI" &
  45                      "DIMENSIONAL AGGREGATE OF THE FORM "   &
  46                      "(F..G => (H..I = J)) IS PERFORMED "   &
  47                      "CORRECTLY");
  48
  49      DECLARE
  50
  51           TYPE CHOICE_INDEX IS (F, G, H, I, J);
  52           TYPE CHOICE_CNTR  IS ARRAY(CHOICE_INDEX) OF INTEGER;
  53
  54           CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0);
  55
  56           SUBTYPE SINT IS INTEGER RANGE 1 .. 8;
  57           TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER;
  58
  59           FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER)
  60                          RETURN INTEGER IS
  61           BEGIN
  62                CNTR(A) := CNTR(A) + 1;
  63                RETURN IDENT_INT(B);
  64           END CALC;
  65
  66      BEGIN
  67
  68 CASE_B :  DECLARE
  69                PROCEDURE CHECK (A : T0; M : STRING) IS
  70                BEGIN
  71                     IF (A'FIRST(1) /= 1) OR (A'LAST(1) /= 9) OR
  72                        (A'FIRST(2) /= 6) OR (A'LAST(2) /= 5) THEN
  73                          FAILED("CASE B" & M & " : ARRAY NOT " &
  74                                 "BOUNDED CORRECTLY");
  75                     END IF;
  76                END CHECK;
  77           BEGIN
  78
  79      CASE_B1 : BEGIN
  80                     CHECK ((1 .. 9 => (6 .. 5 => 2)),"1");
  81                     FAILED ("CASE B1 : CONSTRAINT_ERROR NOT RAISED");
  82                EXCEPTION
  83                     WHEN CONSTRAINT_ERROR =>
  84                          NULL;
  85                     WHEN OTHERS =>
  86                          FAILED("CASE B1 : EXCEPTION RAISED");
  87                END CASE_B1;
  88
  89      CASE_B2 : BEGIN
  90                     CHECK ((CALC(F,1) .. CALC(G,9) => (6 .. 5 => 2)),
  91                            "2");
  92                     FAILED ("CASE B2 : CONSTRAINT_ERROR NOT RAISED");
  93                EXCEPTION
  94                     WHEN CONSTRAINT_ERROR =>
  95                          NULL;
  96                     WHEN OTHERS =>
  97                          FAILED("CASE B2 : EXCEPTION RAISED");
  98                END CASE_B2;
  99
 100      CASE_B3 : BEGIN
 101                     CHECK ((1 .. 9 => (CALC(H,6) .. CALC(I,5) => 2)),
 102                            "3");
 103                     FAILED ("CASE B3 : CONSTRAINT_ERROR NOT RAISED");
 104                EXCEPTION
 105                     WHEN CONSTRAINT_ERROR =>
 106                          NULL;
 107                     WHEN OTHERS =>
 108                          FAILED("CASE B3 : EXCEPTION RAISED");
 109                END CASE_B3;
 110
 111           END CASE_B;
 112
 113      IF CNTR(F) /= 1 THEN
 114           FAILED ("CASE B2 : F WAS NOT EVALUATED " &
 115                   "ONCE.  F WAS EVALUATED"         &
 116                   INTEGER'IMAGE(CNTR(F)) & " TIMES");
 117      END IF;
 118      IF CNTR(G) /= 1 THEN
 119           FAILED ("CASE B2 : G WAS NOT EVALUATED " &
 120                   "ONCE.  G WAS EVALUATED"         &
 121                   INTEGER'IMAGE(CNTR(G)) & " TIMES");
 122      END IF;
 123
 124      IF CNTR(H) /= 0 AND CNTR(I) /= 0 THEN
 125           COMMENT ("CASE B3 : ALL CHOICES " &
 126                    "EVALUATED BEFORE CHECKING " &
 127                    "INDEX SUBTYPE");
 128      ELSIF CNTR(H) = 0 AND CNTR(I) = 0 THEN
 129           COMMENT ("CASE B3 : SUBTYPE CHECKS "&
 130                    "MADE AS CHOICES ARE EVALUATED");
 131      END IF;
 132
 133      IF CNTR(H) > 1 THEN
 134           FAILED("CASE B3 : H WAS NOT EVALUATED " &
 135                  "AT MOST ONCE. H WAS EVALUATED" &
 136                  INTEGER'IMAGE(CNTR(H)) & " TIMES");
 137      END IF;
 138
 139      IF CNTR(I) > 1 THEN
 140           FAILED("CASE B3 : I WAS NOT EVALUATED " &
 141                  "AT MOST ONCE. I WAS EVALUATED" &
 142                  INTEGER'IMAGE(CNTR(I)) & " TIMES");
 143      END IF;
 144
 145      END;
 146
 147      RESULT;
 148
 149 END C43207B;