1-- C453001.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- The Ada Conformity Assessment Authority (ACAA) holds unlimited 6-- rights in the software and documentation contained herein. Unlimited 7-- rights are the same as those granted by the U.S. Government for older 8-- parts of the Ada Conformity Assessment Test Suite, and are defined 9-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA 10-- intends to confer upon all recipients unlimited rights equal to those 11-- held by the ACAA. These rights include rights to use, duplicate, 12-- release or disclose the released technical data and computer software 13-- in whole or in part, in any manner and for any purpose whatsoever, and 14-- to have or permit others to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE ACAA 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-- Notice 26-- 27-- The ACAA has created and maintains the Ada Conformity Assessment Test 28-- Suite for the purpose of conformity assessments conducted in accordance 29-- with the International Standard ISO/IEC 18009 - Ada: Conformity 30-- assessment of a language processor. This test suite should not be used 31-- to make claims of conformance unless used in accordance with 32-- ISO/IEC 18009 and any applicable ACAA procedures. 33--* 34-- OBJECTIVES: 35-- Check that overflow checking is not performed for adding operators of 36-- modular types. 37-- 38-- TEST DESCRIPTION: 39-- Check that Constraint_Error is not raised by + or - when the result 40-- is out of the range of the base type. 41-- Also check that assignment to values in the upper half of the range 42-- does not raise Constraint_Error. 43-- 44-- We define modular types of various common sizes. We cannot 45-- assume a binary modulus greater than 2**16 is supported by 3.5.4(23), 46-- so the DWord type might be smaller on some targets. We also try 47-- a small prime number as a modulus (these are often used for hashing). 48-- We also the language-defined types 49-- System.Storage_Elements.Storage_Element, Ada.Streams.Stream_Element, 50-- and Ada.Containers.Hash_Type. 51-- 52-- CHANGE HISTORY: 53-- 11 Feb 17 JAC Initial pre-release version. 54-- 30 Mar 17 RLB Renamed, removed non-modular test cases, removed 55-- types that aren't required to be supported, added 56-- other language-defined types, added key to locate 57-- failures, added additional test cases. 58-- 03 Apr 17 RLB Removed Ada.Containers from the Ada 95 version of 59-- this test. 60-- 61--! 62with Report; 63with System.Storage_Elements; 64with Ada.Streams; 65 66procedure C453001 is 67 type Unsigned_Byte_Type is mod 16#100#; -- 256; 68 69 type Unsigned_Word_Type is mod 16#1_0000#; -- 65536; 70 71 type Unsigned_DWord_Type is mod 72 Natural'Min (2**32, System.Max_Binary_Modulus); 73 74 type Unsigned_NBM_Type is mod System.Max_Nonbinary_Modulus; 75 76 type Biggest_Unsigned_Type is mod System.Max_Binary_Modulus; 77 78 type Prime_Type is mod 23; -- Prime number for hashing. 79 80 generic 81 type Mod_Type is mod <>; -- Assume this is a base type. 82 Key : in String; 83 procedure Test_Operators; 84 85 procedure Test_Operators is 86 87 function Ident_Mod (Val : in Mod_Type) return Mod_Type is 88 -- Optimization breaker. 89 begin 90 if Report.Equal (4, 12) then -- Always False (but complex). 91 return 1; 92 else 93 return Val; 94 end if; 95 end Ident_Mod; 96 97 begin 98 if Mod_Type'First /= 0 then -- The First of a base type is always 0. 99 Report.Failed ("Not base type first - " & Key); 100 end if; 101 if Mod_Type'Last /= Mod_Type'Base'Last then 102 Report.Failed ("Not base type last - " & Key); 103 end if; 104 105 -- Note: Mod_Type'First always is 0. 106 107 -- Check addition 108 declare 109 M : constant Mod_Type := Mod_Type'Last; 110 V : Mod_Type; 111 begin 112 V := M + 1; -- Should wrap around 113 if Ident_Mod (V) /= 0 then 114 Report.Failed ("Addition didn't wrap round - " & Key); 115 end if; 116 V := Ident_Mod (M - 2) + 5; -- Should wrap around 117 if Ident_Mod (V) /= 2 then 118 Report.Failed ("Addition didn't wrap round again - " & Key); 119 end if; 120 exception 121 when Constraint_Error => 122 Report.Failed ("Constraint_Error raised for addition - " & Key); 123 when others => 124 Report.Failed 125 ("Some even more unexpected exception raised for addition - " & 126 Key); 127 end; 128 129 -- Check subtraction 130 declare 131 M : constant Mod_Type := 0; 132 V : Mod_Type; 133 begin 134 V := M - 1; -- Should wrap around 135 if Ident_Mod (V) /= Mod_Type'Last then 136 Report.Failed ("Subtraction didn't wrap round - " & Key); 137 end if; 138 V := Ident_Mod (3) - 7; -- Should wrap around 139 if Ident_Mod (V) /= Mod_Type'Last-3 then 140 Report.Failed ("Subtraction didn't wrap round again - " & Key); 141 end if; 142 exception 143 when Constraint_Error => 144 Report.Failed ("Constraint_Error raised for subtraction - " & Key); 145 when others => 146 Report.Failed 147 ("Some even more unexpected exception raised for subtraction - " & 148 Key); 149 end; 150 151 end Test_Operators; 152 153 procedure Test_Unsigned_Byte_Operators is new Test_Operators 154 (Unsigned_Byte_Type, "Byte"); 155 156 procedure Test_Unsigned_Word_Operators is new Test_Operators 157 (Unsigned_Word_Type, "Word"); 158 159 procedure Test_Unsigned_DWord_Operators is new Test_Operators 160 (Unsigned_DWord_Type, "DWord"); 161 162 procedure Test_Unsigned_NBM_Operators is new Test_Operators 163 (Unsigned_NBM_Type, "NBM"); 164 165 procedure Test_Biggest_Unsigned_Operators is new Test_Operators 166 (Biggest_Unsigned_Type, "Big"); 167 168 procedure Test_Prime_Operators is new Test_Operators (Prime_Type, "Prime"); 169 170 procedure Test_Storage_Element_Operators is new Test_Operators 171 (System.Storage_Elements.Storage_Element, "Storage"); 172 173 procedure Test_Stream_Element_Operators is new Test_Operators 174 (Ada.Streams.Stream_Element, "Stream"); 175 176begin 177 178 Report.Test 179 ("C453001", 180 "Check that overflow checking is not performed for adding operators " & 181 "of modular types"); 182 183 -- Check assignment 184 declare 185 -- Define subtypes 186 subtype My_Unsigned_Byte_Type is Unsigned_Byte_Type; 187 subtype My_Unsigned_Word_Type is Unsigned_Word_Type; 188 subtype My_Unsigned_DWord_Type is Unsigned_DWord_Type; 189 190 -- Define constants in upper half of range 191 C1 : constant Unsigned_Byte_Type := Unsigned_Byte_Type'Last; 192 C2 : constant My_Unsigned_Byte_Type := 16#FE#; 193 C3 : constant Unsigned_Word_Type := 16#FACE#; 194 C4 : constant My_Unsigned_Word_Type := My_Unsigned_Word_Type'Last; 195 C5 : constant Unsigned_DWord_Type := My_Unsigned_DWord_Type'Last; 196 197 -- Define variables 198 V1 : Unsigned_Byte_Type; 199 V2 : My_Unsigned_Byte_Type; 200 V3 : Unsigned_Word_Type; 201 V4 : My_Unsigned_Word_Type; 202 V5 : Unsigned_DWord_Type; 203 begin 204 V1 := C1; 205 V1 := C2; 206 V2 := C1; 207 V2 := C2; 208 V3 := C3; 209 V3 := C4; 210 V4 := C3; 211 V4 := C4; 212 V5 := C5; 213 if V1 /= C2 or V2 /= C2 or V3 /= C4 or V4 /= C4 or V5 /= C5 then 214 Report.Comment ("Don't optimize assignment!"); -- Optimization breaker 215 end if; 216 exception 217 when Constraint_Error => 218 Report.Failed ("Constraint_Error raised for assignment"); 219 when others => 220 Report.Failed ("Some even more unexpected exception raised " & 221 "for assignment"); 222 end; 223 224 Test_Unsigned_Byte_Operators; 225 Test_Unsigned_Word_Operators; 226 Test_Unsigned_DWord_Operators; 227 Test_Unsigned_NBM_Operators; 228 Test_Biggest_Unsigned_Operators; 229 Test_Prime_Operators; 230 Test_Storage_Element_Operators; 231 Test_Stream_Element_Operators; 232 233 Report.Result; 234 235end C453001; 236 237