gcc/testsuite/ada/acats/tests/c3/c354003.a

   1 -- C354003.A
   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 --
  26 -- OBJECTIVE:
  27 --      Check that the Wide_String attributes of modular types yield
  28 --      correct values/results.  The attributes checked are:
  29 --
  30 --      Wide_Image
  31 --      Wide_Value
  32 --
  33 -- TEST DESCRIPTION:
  34 --      This test is split from C354002.  It tests only the attributes:
  35 --
  36 --      Wide_Image, Wide_Value
  37 --
  38 --      This test defines several modular types.  One type defined at
  39 --      each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus,
  40 --      a power of two half that of System.Max_Binary_Modulus, one less
  41 --      than that power of two; one more than that power of two, two
  42 --      less than a (large) power of two.  For each of these types,
  43 --      determine the correct operation of the Wide_String attributes.
  44 --
  45 --
  46 -- CHANGE HISTORY:
  47 --      13 DEC 94   SAIC    Initial version
  48 --      06 JAN 94   SAIC    Promoted to future release
  49 --      19 APR 95   SAIC    Revised in accord with reviewer comments
  50 --      01 DEC 95   SAIC    Corrected for 2.0.1
  51 --      27 JAN 96   SAIC    Eliminated potential 32/64 bit conflict for 2.1
  52 --      24 FEB 97   PWB.CTA Corrected out-of-range value
  53 --!
  54
  55 with Report;
  56 with System;
  57 with TCTouch;
  58 with Ada.Characters.Handling;
  59 procedure C354003 is
  60
  61   function ID(Local_Value: Integer) return Integer renames Report.Ident_Int;
  62   function ID(Local_Value: String)  return String renames  Report.Ident_Str;
  63
  64   function ID(Local_Value: String) return Wide_String is
  65   begin
  66     return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) );
  67   end ID;
  68
  69   Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2;
  70
  71   type Max_Binary      is mod System.Max_Binary_Modulus;
  72   type Max_NonBinary   is mod System.Max_Nonbinary_Modulus;
  73   type Half_Max_Binary is mod Half_Max_Binary_Value;
  74
  75   type Medium          is mod 2048;
  76   type Medium_Plus     is mod 2042;
  77   type Medium_Minus    is mod 2111;
  78
  79   type Small  is mod 2;
  80   type Finger is mod 5;
  81
  82   type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie);
  83
  84   subtype Midrange is Medium_Minus range 222 .. 1111;
  85
  86   AMB,   BMB   : Max_Binary;
  87   AHMB,  BHMB  : Half_Max_Binary;
  88   AM,    BM    : Medium;
  89   AMP,   BMP   : Medium_Plus;
  90   AMM,   BMM   : Medium_Minus;
  91   AS,    BS    : Small;
  92   AF,    BF    : Finger;
  93
  94   procedure Wide_Value_Fault( S: Wide_String ) is
  95   -- check 'Wide_Value for failure modes
  96   begin
  97     -- the evaluation of the 'Wide_Value expression should raise C_E
  98     TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" );
  99     if Midrange'Wide_Value(S) not in Midrange'Base then
 100       Report.Failed("'Wide_Value  raised no exception");
 101     end if;
 102   exception
 103     when Constraint_Error => null; -- expected case
 104     when others =>
 105          Report.Failed("'Wide_Value raised wrong exception");
 106   end Wide_Value_Fault;
 107
 108
 109   The_Cap, The_Toe : Natural;
 110
 111   procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is
 112     subtype Non_Static is Medium range Lower_Bound..Upper_Bound;
 113   begin
 114   -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val
 115
 116     TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" );
 117     TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap),
 118                     "Non_Static'Last" );
 119     TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range,
 120                     "Non_Static'Range" );
 121     TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)),
 122                                    Medium(Report.Ident_Int(200))) = 100,
 123                     "Non_Static'Min" );
 124     TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)),
 125                                    Medium(Report.Ident_Int(200))) = 200,
 126                     "Non_Static'Max" );
 127     TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap))
 128                     = Medium'Succ(Upper_Bound),
 129                     "Non_Static'Succ" );
 130     TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap)))
 131                     = Non_Static(Report.Ident_Int(The_Cap-1)),
 132                     "Non_Static'Pred" );
 133     TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap),
 134                     "Non_Static'Pos" );
 135     TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound,
 136                     "Non_Static'Val" );
 137
 138   end Check_Non_Static_Cases;
 139
 140
 141 begin  -- Main test procedure.
 142
 143   Report.Test ("C354003", "Check Wide_String attributes of modular types" );
 144
 145   Wide_Strings_Needed: declare
 146
 147     Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3;
 148     Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4;
 149
 150   begin
 151
 152 -- Wide_Image
 153
 154     TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255",
 155                    "Half_Max_Binary'Wide_Image" );
 156
 157     TCTouch.Assert( Medium'Wide_Image(0) = " 0",  "Medium'Wide_Image" );
 158
 159     TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041",
 160                    "Medium_Plus'Wide_Image" );
 161
 162     TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024",
 163                    "Medium_Minus'Wide_Image" );
 164
 165     TCTouch.Assert( Small'Wide_Image(1) = " 1",   "Small'Wide_Image" );
 166
 167     TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333",
 168                    "Midrange'Wide_Image" );
 169
 170 -- Wide_Value
 171
 172     TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255,
 173                    "Half_Max_Binary'Wide_Value" );
 174
 175     TCTouch.Assert( Medium'Wide_Value(" 0 ")  = 0,   "Medium'Wide_Value" );
 176
 177     TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last,
 178                    "Medium_Plus'Wide_Value" );
 179
 180     TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14,
 181                    "Medium_Minus'Wide_Value" );
 182
 183     TCTouch.Assert( Small'Wide_Value("+1") = 1,      "Small'Wide_Value" );
 184
 185     TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333,
 186                    "Midrange'Wide_Value" );
 187
 188     TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000,
 189                    "Midrange'Wide_Value(""1E3"")" );
 190
 191     Wide_Value_Fault( "bad input" );
 192     Wide_Value_Fault( "-333" );
 193     Wide_Value_Fault( "9999" );
 194     Wide_Value_Fault( ".1" );
 195     Wide_Value_Fault( "1e-1" );
 196
 197   end Wide_Strings_Needed;
 198
 199   The_Toe := Report.Ident_Int(25);
 200   The_Cap := Report.Ident_Int(256);
 201   Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
 202                           Medium(Report.Ident_Int(The_Cap)) );
 203
 204   The_Toe := Report.Ident_Int(40);
 205   The_Cap := Report.Ident_Int(2047);
 206   Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)),
 207                           Medium(Report.Ident_Int(The_Cap)) );
 208
 209   Report.Result;
 210
 211 end C354003;