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