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

   1 -- C45232B.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 NO EXCEPTION IS RAISED WHEN AN INTEGER LITERAL IN
  26 -- A COMPARISON  BELONGS TO THE BASE TYPE BUT IS OUTSIDE THE
  27 -- SUBTYPE OF THE OTHER OPERAND.
  28
  29 -- *** NOTE: This test has been modified since ACVC version 1.11 to    -- 9X
  30 -- ***       remove incompatibilities associated with the transition   -- 9X
  31 -- ***       to Ada 9X.                                                -- 9X
  32
  33 -- P. BRASHEAR  08/21/86
  34 -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST.
  35
  36 WITH REPORT, SYSTEM; USE REPORT;
  37 PROCEDURE C45232B IS
  38
  39 BEGIN
  40
  41      TEST ("C45232B", "NO EXCEPTION IS RAISED WHEN AN INTEGER " &
  42                       "LITERAL IN A COMPARISON BELONGS TO THE BASE " &
  43                       "TYPE BUT IS OUTSIDE THE SUBTYPE OF THE " &
  44                       "OTHER OPERAND");
  45
  46      DECLARE
  47
  48            TYPE INT10 IS RANGE -10 .. 5;
  49
  50      BEGIN
  51
  52           IF 7 > INT10'(-10) THEN
  53                COMMENT ("NO EXCEPTION RAISED FOR '7 > " &
  54                         "INT10'(-10)'");
  55           ELSE
  56                FAILED ("WRONG RESULT FOR '7 > INT10'(-10)'");
  57           END IF;
  58
  59      EXCEPTION
  60           WHEN CONSTRAINT_ERROR =>
  61                FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " &
  62                        "> INT10'(-10)'");
  63           WHEN OTHERS =>
  64                FAILED ("OTHER EXCEPTION RAISED FOR '7 > " &
  65                        "INT10'(-10)'");
  66      END;
  67
  68      DECLARE
  69
  70            TYPE INT10 IS RANGE -10 .. 5;
  71
  72      BEGIN
  73
  74           IF 7 NOT IN INT10 THEN
  75                COMMENT ("NO EXCEPTION RAISED FOR '7 NOT IN " &
  76                         "INT'");
  77           ELSE
  78                FAILED ("WRONG RESULT FOR '7 NOT IN INT'");
  79           END IF;
  80
  81      EXCEPTION
  82           WHEN CONSTRAINT_ERROR =>
  83                FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " &
  84                        "NOT IN INT'");
  85           WHEN OTHERS =>
  86                FAILED ("OTHER EXCEPTION RAISED FOR '7 NOT IN " &
  87                        "INT'");
  88      END;
  89
  90      DECLARE
  91
  92            TYPE INT700 IS RANGE -700 .. 500;
  93
  94      BEGIN
  95           IF 600 > INT700'(5) THEN
  96                COMMENT ("NO EXCEPTION RAISED FOR '600 > " &
  97                         "INT700'(5)'");
  98           ELSE
  99                FAILED ("WRONG RESULT FOR '600 > INT700'(5)'");
 100           END IF;
 101
 102      EXCEPTION
 103           WHEN CONSTRAINT_ERROR =>
 104                FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " &
 105                        "> INT700'(5)'");
 106           WHEN OTHERS =>
 107                FAILED ("OTHER EXCEPTION RAISED FOR '600 > " &
 108                        "INT700'(5)'");
 109      END;
 110
 111      DECLARE
 112
 113            TYPE INT700 IS RANGE -700 .. 500;
 114
 115      BEGIN
 116
 117           IF 600 NOT IN INT700 THEN
 118                COMMENT ("NO EXCEPTION RAISED FOR '600 NOT IN " &
 119                         "INT700'");
 120           ELSE
 121                FAILED ("WRONG RESULT FOR '600 NOT IN INT700'");
 122           END IF;
 123
 124      EXCEPTION
 125           WHEN CONSTRAINT_ERROR =>
 126                FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " &
 127                        "NOT IN INT700'");
 128           WHEN OTHERS =>
 129                FAILED ("OTHER EXCEPTION RAISED FOR '600 NOT IN " &
 130                        "INT700'");
 131      END;
 132
 133      RESULT;
 134
 135 END C45232B;