old-autovect-branch/gcc/testsuite/ada/acats/tests/c4/c43215b.ada

   1 -- C43215B.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 WHEN THE UPPER BOUND
  26 -- OF A POSITIONAL AGGREGATE DOES NOT BELONG TO THE INDEX BASE TYPE.
  27
  28 -- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
  29 -- ***       remove incompatibilities associated with the transition   -- 9X
  30 -- ***       to Ada 9X.                                                -- 9X
  31
  32 -- EG  02/13/84
  33 -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
  34
  35 WITH REPORT;
  36 WITH SYSTEM;
  37
  38 PROCEDURE C43215B IS
  39
  40      USE REPORT;
  41      USE SYSTEM;
  42
  43 BEGIN
  44
  45      TEST("C43215B","CHECK THAT CONSTRAINT_ERROR IS RAISED "   &
  46                     "WHEN THE UPPER BOUND OF A POSITIONAL ARRAY " &
  47                     "AGGREGATE DOES NOT BELONG TO THE INDEX "     &
  48                     "BASE TYPE");
  49
  50      BEGIN
  51
  52 CASE_A :  DECLARE
  53
  54                LOWER_BOUND : CONSTANT := MAX_INT-3;
  55                UPPER_BOUND : CONSTANT := MAX_INT-1;
  56
  57                TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND;
  58
  59                TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER;
  60
  61                A1 : TA(STA);
  62                OK : EXCEPTION;
  63
  64                FUNCTION FUN1 RETURN TA IS
  65                BEGIN
  66                     RETURN (1, 2, 3, 4, 5);
  67                EXCEPTION
  68                     WHEN CONSTRAINT_ERROR =>
  69                     BEGIN
  70                          COMMENT ("CASE A : CONSTRAINT_ERROR RAISED");
  71                          RAISE OK;
  72                     END;
  73                     WHEN OTHERS =>
  74                     BEGIN
  75                          FAILED ("CASE A : EXCEPTION RAISED IN FUN1");
  76                          RAISE OK;
  77                     END;
  78                END FUN1;
  79
  80           BEGIN
  81
  82                A1 := FUN1;
  83                FAILED ("CASE A : CONSTRAINT OR NUMERIC ERROR WAS " &
  84                        "NOT RAISED");
  85
  86           EXCEPTION
  87
  88                WHEN OK =>
  89                     NULL;
  90
  91                WHEN OTHERS =>
  92                     FAILED ("CASE A : WRONG EXCEPTION RAISED");
  93
  94           END CASE_A;
  95
  96 CASE_B :  DECLARE
  97
  98                TYPE ENUM IS (A, B, C, D);
  99
 100                SUBTYPE STB IS ENUM RANGE A .. C;
 101
 102                TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER;
 103
 104                B1 : TB(STB);
 105                OK : EXCEPTION;
 106
 107                FUNCTION FUN1 RETURN TB IS
 108                BEGIN
 109                     RETURN (1, 2, 3, 4, 5);
 110                EXCEPTION
 111                     WHEN CONSTRAINT_ERROR =>
 112                     BEGIN
 113                          COMMENT ("CASE B : CONSTRAINT_ERROR RAISED");
 114                          RAISE OK;
 115                     END;
 116                     WHEN OTHERS =>
 117                     BEGIN
 118                          FAILED ("CASE B : EXCEPTION RAISED IN FUN1");
 119                          RAISE OK;
 120                     END;
 121                END FUN1;
 122
 123           BEGIN
 124
 125                B1 := FUN1;
 126                FAILED ("CASE B : CONSTRAINT ERROR WAS NOT RAISED");
 127
 128           EXCEPTION
 129
 130                WHEN OK =>
 131                     NULL;
 132
 133                WHEN OTHERS =>
 134                     FAILED ("CASE B : WRONG EXCEPTION RAISED");
 135
 136           END CASE_B;
 137
 138      END;
 139
 140      RESULT;
 141
 142 END C43215B;