Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/cxg/cxg2001.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- CXG2001.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 floating point attributes Model_Mantissa, | |
28 -- Machine_Mantissa, Machine_Radix, and Machine_Rounds | |
29 -- are properly reported. | |
30 -- | |
31 -- TEST DESCRIPTION: | |
32 -- This test uses a generic package to compute and check the | |
33 -- values of the Machine_ attributes listed above. The | |
34 -- generic package is instantiated with the standard FLOAT | |
35 -- type and a floating point type for the maximum number | |
36 -- of digits of precision. | |
37 -- | |
38 -- APPLICABILITY CRITERIA: | |
39 -- This test applies only to implementations supporting the | |
40 -- Numerics Annex. | |
41 -- | |
42 -- | |
43 -- CHANGE HISTORY: | |
44 -- 26 JAN 96 SAIC Initial Release for 2.1 | |
45 -- | |
46 --! | |
47 | |
48 -- References: | |
49 -- | |
50 -- "Algorithms To Reveal Properties of Floating-Point Arithmetic" | |
51 -- Michael A. Malcolm; CACM November 1972; pgs 949-951. | |
52 -- | |
53 -- Software Manual for Elementary Functions; W. J. Cody and W. Waite; | |
54 -- Prentice-Hall; 1980 | |
55 ----------------------------------------------------------------------- | |
56 -- | |
57 -- This test relies upon the fact that | |
58 -- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding | |
59 -- a small value to A does not change the value of A. Consider the case | |
60 -- where we have a decimal based floating point representation with 4 | |
61 -- digits of precision. A floating point number would logically be | |
62 -- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9. | |
63 -- The first loop of the test starts A at 2.0 and doubles it until | |
64 -- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point | |
65 -- number this will be 1638 * 10**1 (the value 16384 rounded or truncated | |
66 -- to fit in 4 digits). | |
67 -- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is | |
68 -- no longer 0. This will keep looping until B is 8.0 because that is | |
69 -- the first value where rounding (assuming our machine rounds and addition | |
70 -- employs a guard digit) will change the upper 4 digits of the result: | |
71 -- 1638_ | |
72 -- + 8 | |
73 -- ------- | |
74 -- 1639_ | |
75 -- Without rounding the second loop will continue until | |
76 -- B is 16: | |
77 -- 1638_ | |
78 -- + 16 | |
79 -- ------- | |
80 -- 1639_ | |
81 -- | |
82 -- The radix is then determined by (A+B)-A which will give 10. | |
83 -- | |
84 -- The use of Tmp and ITmp in the test is to force values to be | |
85 -- stored into memory in the event that register precision is greater | |
86 -- than the stored precision of the floating point values. | |
87 -- | |
88 -- | |
89 -- The test for rounding is (ignoring the temporary variables used to | |
90 -- get the stored precision) is | |
91 -- Rounds := A + Radix/2.0 - A /= 0.0 ; | |
92 -- where A is the value determined in the first step that is the smallest | |
93 -- power of 2 such that A + 1.0 = A. This means that the true value of | |
94 -- A has one more digit in its value than 'Machine_Mantissa. | |
95 -- This check will detect the case where a value is always rounded. | |
96 -- There is an additional case where values are rounded to the nearest | |
97 -- even value. That is referred to as IEEE style rounding in the test. | |
98 -- | |
99 ----------------------------------------------------------------------- | |
100 | |
101 with System; | |
102 with Report; | |
103 with Ada.Numerics.Generic_Elementary_Functions; | |
104 procedure CXG2001 is | |
105 Verbose : constant Boolean := False; | |
106 | |
107 -- if one of the attribute computation loops exceeds Max_Iterations | |
108 -- it is most likely due to the compiler reordering an expression | |
109 -- that should not be reordered. | |
110 Illegal_Optimization : exception; | |
111 Max_Iterations : constant := 10_000; | |
112 | |
113 generic | |
114 type Real is digits <>; | |
115 package Chk_Attrs is | |
116 procedure Do_Test; | |
117 end Chk_Attrs; | |
118 | |
119 package body Chk_Attrs is | |
120 package EF is new Ada.Numerics.Generic_Elementary_Functions (Real); | |
121 function Log (X : Real) return Real renames EF.Log; | |
122 | |
123 | |
124 -- names used in paper | |
125 Radix : Integer; -- Beta | |
126 Mantissa_Digits : Integer; -- t | |
127 Rounds : Boolean; -- RND | |
128 | |
129 -- made global to Determine_Attributes to help thwart optimization | |
130 A, B : Real := 2.0; | |
131 Tmp, Tmpa, Tmp1 : Real; | |
132 ITmp : Integer; | |
133 Half_Radix : Real; | |
134 | |
135 -- special constants - not declared as constants so that | |
136 -- the "stored" precision will be used instead of a "register" | |
137 -- precision. | |
138 Zero : Real := 0.0; | |
139 One : Real := 1.0; | |
140 Two : Real := 2.0; | |
141 | |
142 | |
143 procedure Thwart_Optimization is | |
144 -- the purpose of this procedure is to reference the | |
145 -- global variables used by Determine_Attributes so | |
146 -- that the compiler is not likely to keep them in | |
147 -- a higher precision register for their entire lifetime. | |
148 begin | |
149 if Report.Ident_Bool (False) then | |
150 -- never executed | |
151 A := A + 5.0; | |
152 B := B + 6.0; | |
153 Tmp := Tmp + 1.0; | |
154 Tmp1 := Tmp1 + 2.0; | |
155 Tmpa := Tmpa + 2.0; | |
156 One := 12.34; Two := 56.78; Zero := 90.12; | |
157 end if; | |
158 end Thwart_Optimization; | |
159 | |
160 | |
161 -- determines values for Radix, Mantissa_Digits, and Rounds | |
162 -- This is mostly a straight translation of the C code. | |
163 -- The only significant addition is the iteration count | |
164 -- to prevent endless looping if things are really screwed up. | |
165 procedure Determine_Attributes is | |
166 Iterations : Integer; | |
167 begin | |
168 Rounds := True; | |
169 | |
170 Iterations := 0; | |
171 Tmp := Real'Machine (((A + One) - A) - One); | |
172 while Tmp = Zero loop | |
173 A := Real'Machine(A + A); | |
174 Tmp := Real'Machine(A + One); | |
175 Tmp1 := Real'Machine(Tmp - A); | |
176 Tmp := Real'Machine(Tmp1 - One); | |
177 | |
178 Iterations := Iterations + 1; | |
179 if Iterations > Max_Iterations then | |
180 raise Illegal_Optimization; | |
181 end if; | |
182 end loop; | |
183 | |
184 Iterations := 0; | |
185 Tmp := Real'Machine(A + B); | |
186 ITmp := Integer (Tmp - A); | |
187 while ITmp = 0 loop | |
188 B := Real'Machine(B + B); | |
189 Tmp := Real'Machine(A + B); | |
190 ITmp := Integer (Tmp - A); | |
191 | |
192 Iterations := Iterations + 1; | |
193 if Iterations > Max_Iterations then | |
194 raise Illegal_Optimization; | |
195 end if; | |
196 end loop; | |
197 | |
198 Radix := ITmp; | |
199 | |
200 Mantissa_Digits := 0; | |
201 B := 1.0; | |
202 Tmp := Real'Machine(((B + One) - B) - One); | |
203 Iterations := 0; | |
204 while (Tmp = Zero) loop | |
205 Mantissa_Digits := Mantissa_Digits + 1; | |
206 B := B * Real (Radix); | |
207 Tmp := Real'Machine(B + One); | |
208 Tmp1 := Real'Machine(Tmp - B); | |
209 Tmp := Real'Machine(Tmp1 - One); | |
210 | |
211 Iterations := Iterations + 1; | |
212 if Iterations > Max_Iterations then | |
213 raise Illegal_Optimization; | |
214 end if; | |
215 end loop; | |
216 | |
217 Rounds := False; | |
218 Half_Radix := Real (Radix) / Two; | |
219 Tmp := Real'Machine(A + Half_Radix); | |
220 Tmp1 := Real'Machine(Tmp - A); | |
221 if (Tmp1 /= Zero) then | |
222 Rounds := True; | |
223 end if; | |
224 Tmpa := Real'Machine(A + Real (Radix)); | |
225 Tmp := Real'Machine(Tmpa + Half_Radix); | |
226 if not Rounds and (Tmp - TmpA /= Zero) then | |
227 Rounds := True; | |
228 if Verbose then | |
229 Report.Comment ("IEEE style rounding"); | |
230 end if; | |
231 end if; | |
232 | |
233 exception | |
234 when others => | |
235 Thwart_Optimization; | |
236 raise; | |
237 end Determine_Attributes; | |
238 | |
239 | |
240 procedure Do_Test is | |
241 Show_Results : Boolean := Verbose; | |
242 Min_Mantissa_Digits : Integer; | |
243 begin | |
244 -- compute the actual Machine_* attribute values | |
245 Determine_Attributes; | |
246 | |
247 if Real'Machine_Radix /= Radix then | |
248 Report.Failed ("'Machine_Radix incorrectly reports" & | |
249 Integer'Image (Real'Machine_Radix)); | |
250 Show_Results := True; | |
251 end if; | |
252 | |
253 if Real'Machine_Mantissa /= Mantissa_Digits then | |
254 Report.Failed ("'Machine_Mantissa incorrectly reports" & | |
255 Integer'Image (Real'Machine_Mantissa)); | |
256 Show_Results := True; | |
257 end if; | |
258 | |
259 if Real'Machine_Rounds /= Rounds then | |
260 Report.Failed ("'Machine_Rounds incorrectly reports " & | |
261 Boolean'Image (Real'Machine_Rounds)); | |
262 Show_Results := True; | |
263 end if; | |
264 | |
265 if Show_Results then | |
266 Report.Comment ("computed Machine_Mantissa is" & | |
267 Integer'Image (Mantissa_Digits)); | |
268 Report.Comment ("computed Radix is" & | |
269 Integer'Image (Radix)); | |
270 Report.Comment ("computed Rounds is " & | |
271 Boolean'Image (Rounds)); | |
272 end if; | |
273 | |
274 -- check the model attributes against the machine attributes | |
275 -- G.2.2(3)/3;6.0 | |
276 if Real'Model_Mantissa > Real'Machine_Mantissa then | |
277 Report.Failed ("model mantissa > machine mantissa"); | |
278 end if; | |
279 | |
280 -- G.2.2(3)/2;6.0 | |
281 -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1 | |
282 Min_Mantissa_Digits := | |
283 Integer ( | |
284 Real'Ceiling ( | |
285 Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix)) | |
286 ) ) + 1; | |
287 if Real'Model_Mantissa < Min_Mantissa_Digits then | |
288 Report.Failed ("Model_Mantissa [" & | |
289 Integer'Image (Real'Model_Mantissa) & | |
290 "] < minimum mantissa digits [" & | |
291 Integer'Image (Min_Mantissa_Digits) & | |
292 "]"); | |
293 end if; | |
294 | |
295 exception | |
296 when Illegal_Optimization => | |
297 Report.Failed ("illegal optimization of" & | |
298 " floating point expression"); | |
299 end Do_Test; | |
300 end Chk_Attrs; | |
301 | |
302 package Chk_Float is new Chk_Attrs (Float); | |
303 | |
304 -- check the floating point type with the most digits | |
305 type A_Long_Float is digits System.Max_Digits; | |
306 package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float); | |
307 begin | |
308 Report.Test ("CXG2001", | |
309 "Check the attributes Model_Mantissa," & | |
310 " Machine_Mantissa, Machine_Radix," & | |
311 " and Machine_Rounds"); | |
312 | |
313 Report.Comment ("checking Standard.Float"); | |
314 Chk_Float.Do_Test; | |
315 | |
316 Report.Comment ("checking a digits" & | |
317 Integer'Image (System.Max_Digits) & | |
318 " floating point type"); | |
319 Chk_A_Long_Float.Do_Test; | |
320 | |
321 Report.Result; | |
322 end CXG2001; |