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 55with Report; 56with System; 57with TCTouch; 58with Ada.Characters.Handling; 59procedure 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 141begin -- 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 211end C354003; 212