|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . I M G _ R E A L --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with System.Img_LLU; use System.Img_LLU;
|
|
|
33 with System.Img_Uns; use System.Img_Uns;
|
|
|
34 with System.Powten_Table; use System.Powten_Table;
|
|
|
35 with System.Unsigned_Types; use System.Unsigned_Types;
|
|
|
36 with System.Float_Control;
|
|
|
37
|
|
|
38 package body System.Img_Real is
|
|
|
39
|
|
|
40 -- The following defines the maximum number of digits that we can convert
|
|
|
41 -- accurately. This is limited by the precision of Long_Long_Float, and
|
|
|
42 -- also by the number of digits we can hold in Long_Long_Unsigned, which
|
|
|
43 -- is the integer type we use as an intermediate for the result.
|
|
|
44
|
|
|
45 -- We assume that in practice, the limitation will come from the digits
|
|
|
46 -- value, rather than the integer value. This is true for typical IEEE
|
|
|
47 -- implementations, and at worst, the only loss is for some precision
|
|
|
48 -- in very high precision floating-point output.
|
|
|
49
|
|
|
50 -- Note that in the following, the "-2" accounts for the sign and one
|
|
|
51 -- extra digits, since we need the maximum number of 9's that can be
|
|
|
52 -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
|
|
|
53 -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
|
|
|
54 -- but the maximum number of 9's that can be supported is 19.
|
|
|
55
|
|
|
56 Maxdigs : constant :=
|
|
|
57 Natural'Min
|
|
|
58 (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
|
|
|
59
|
|
|
60 Unsdigs : constant := Unsigned'Width - 2;
|
|
|
61 -- Number of digits that can be converted using type Unsigned
|
|
|
62 -- See above for the explanation of the -2.
|
|
|
63
|
|
|
64 Maxscaling : constant := 5000;
|
|
|
65 -- Max decimal scaling required during conversion of floating-point
|
|
|
66 -- numbers to decimal. This is used to defend against infinite
|
|
|
67 -- looping in the conversion, as can be caused by erroneous executions.
|
|
|
68 -- The largest exponent used on any current system is 2**16383, which
|
|
|
69 -- is approximately 10**4932, and the highest number of decimal digits
|
|
|
70 -- is about 35 for 128-bit floating-point formats, so 5000 leaves
|
|
|
71 -- enough room for scaling such values
|
|
|
72
|
|
|
73 function Is_Negative (V : Long_Long_Float) return Boolean;
|
|
|
74 pragma Import (Intrinsic, Is_Negative);
|
|
|
75
|
|
|
76 --------------------------
|
|
|
77 -- Image_Floating_Point --
|
|
|
78 --------------------------
|
|
|
79
|
|
|
80 procedure Image_Floating_Point
|
|
|
81 (V : Long_Long_Float;
|
|
|
82 S : in out String;
|
|
|
83 P : out Natural;
|
|
|
84 Digs : Natural)
|
|
|
85 is
|
|
|
86 pragma Assert (S'First = 1);
|
|
|
87
|
|
|
88 begin
|
|
|
89 -- Decide whether a blank should be prepended before the call to
|
|
|
90 -- Set_Image_Real. We generate a blank for positive values, and
|
|
|
91 -- also for positive zeroes. For negative zeroes, we generate a
|
|
|
92 -- space only if Signed_Zeroes is True (the RM only permits the
|
|
|
93 -- output of -0.0 on targets where this is the case). We can of
|
|
|
94 -- course still see a -0.0 on a target where Signed_Zeroes is
|
|
|
95 -- False (since this attribute refers to the proper handling of
|
|
|
96 -- negative zeroes, not to their existence). We do not generate
|
|
|
97 -- a blank for positive infinity, since we output an explicit +.
|
|
|
98
|
|
|
99 if (not Is_Negative (V) and then V <= Long_Long_Float'Last)
|
|
|
100 or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
|
|
|
101 then
|
|
|
102 S (1) := ' ';
|
|
|
103 P := 1;
|
|
|
104 else
|
|
|
105 P := 0;
|
|
|
106 end if;
|
|
|
107
|
|
|
108 Set_Image_Real (V, S, P, 1, Digs - 1, 3);
|
|
|
109 end Image_Floating_Point;
|
|
|
110
|
|
|
111 --------------------------------
|
|
|
112 -- Image_Ordinary_Fixed_Point --
|
|
|
113 --------------------------------
|
|
|
114
|
|
|
115 procedure Image_Ordinary_Fixed_Point
|
|
|
116 (V : Long_Long_Float;
|
|
|
117 S : in out String;
|
|
|
118 P : out Natural;
|
|
|
119 Aft : Natural)
|
|
|
120 is
|
|
|
121 pragma Assert (S'First = 1);
|
|
|
122
|
|
|
123 begin
|
|
|
124 -- Output space at start if non-negative
|
|
|
125
|
|
|
126 if V >= 0.0 then
|
|
|
127 S (1) := ' ';
|
|
|
128 P := 1;
|
|
|
129 else
|
|
|
130 P := 0;
|
|
|
131 end if;
|
|
|
132
|
|
|
133 Set_Image_Real (V, S, P, 1, Aft, 0);
|
|
|
134 end Image_Ordinary_Fixed_Point;
|
|
|
135
|
|
|
136 --------------------
|
|
|
137 -- Set_Image_Real --
|
|
|
138 --------------------
|
|
|
139
|
|
|
140 procedure Set_Image_Real
|
|
|
141 (V : Long_Long_Float;
|
|
|
142 S : out String;
|
|
|
143 P : in out Natural;
|
|
|
144 Fore : Natural;
|
|
|
145 Aft : Natural;
|
|
|
146 Exp : Natural)
|
|
|
147 is
|
|
|
148 NFrac : constant Natural := Natural'Max (Aft, 1);
|
|
|
149 Sign : Character;
|
|
|
150 X : Long_Long_Float;
|
|
|
151 Scale : Integer;
|
|
|
152 Expon : Integer;
|
|
|
153
|
|
|
154 Field_Max : constant := 255;
|
|
|
155 -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last.
|
|
|
156 -- It is not worth dragging in Ada.Text_IO to pick up this value,
|
|
|
157 -- since it really should never be necessary to change it.
|
|
|
158
|
|
|
159 Digs : String (1 .. 2 * Field_Max + 16);
|
|
|
160 -- Array used to hold digits of converted integer value. This is a
|
|
|
161 -- large enough buffer to accommodate ludicrous values of Fore and Aft.
|
|
|
162
|
|
|
163 Ndigs : Natural;
|
|
|
164 -- Number of digits stored in Digs (and also subscript of last digit)
|
|
|
165
|
|
|
166 procedure Adjust_Scale (S : Natural);
|
|
|
167 -- Adjusts the value in X by multiplying or dividing by a power of
|
|
|
168 -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
|
|
|
169 -- adding 0.5 to round the result, readjusting if the rounding causes
|
|
|
170 -- the result to wander out of the range. Scale is adjusted to reflect
|
|
|
171 -- the power of ten used to divide the result (i.e. one is added to
|
|
|
172 -- the scale value for each division by 10.0, or one is subtracted
|
|
|
173 -- for each multiplication by 10.0).
|
|
|
174
|
|
|
175 procedure Convert_Integer;
|
|
|
176 -- Takes the value in X, outputs integer digits into Digs. On return,
|
|
|
177 -- Ndigs is set to the number of digits stored. The digits are stored
|
|
|
178 -- in Digs (1 .. Ndigs),
|
|
|
179
|
|
|
180 procedure Set (C : Character);
|
|
|
181 -- Sets character C in output buffer
|
|
|
182
|
|
|
183 procedure Set_Blanks_And_Sign (N : Integer);
|
|
|
184 -- Sets leading blanks and minus sign if needed. N is the number of
|
|
|
185 -- positions to be filled (a minus sign is output even if N is zero
|
|
|
186 -- or negative, but for a positive value, if N is non-positive, then
|
|
|
187 -- the call has no effect).
|
|
|
188
|
|
|
189 procedure Set_Digs (S, E : Natural);
|
|
|
190 -- Set digits S through E from Digs buffer. No effect if S > E
|
|
|
191
|
|
|
192 procedure Set_Special_Fill (N : Natural);
|
|
|
193 -- After outputting +Inf, -Inf or NaN, this routine fills out the
|
|
|
194 -- rest of the field with * characters. The argument is the number
|
|
|
195 -- of characters output so far (either 3 or 4)
|
|
|
196
|
|
|
197 procedure Set_Zeros (N : Integer);
|
|
|
198 -- Set N zeros, no effect if N is negative
|
|
|
199
|
|
|
200 pragma Inline (Set);
|
|
|
201 pragma Inline (Set_Digs);
|
|
|
202 pragma Inline (Set_Zeros);
|
|
|
203
|
|
|
204 ------------------
|
|
|
205 -- Adjust_Scale --
|
|
|
206 ------------------
|
|
|
207
|
|
|
208 procedure Adjust_Scale (S : Natural) is
|
|
|
209 Lo : Natural;
|
|
|
210 Hi : Natural;
|
|
|
211 Mid : Natural;
|
|
|
212 XP : Long_Long_Float;
|
|
|
213
|
|
|
214 begin
|
|
|
215 -- Cases where scaling up is required
|
|
|
216
|
|
|
217 if X < Powten (S - 1) then
|
|
|
218
|
|
|
219 -- What we are looking for is a power of ten to multiply X by
|
|
|
220 -- so that the result lies within the required range.
|
|
|
221
|
|
|
222 loop
|
|
|
223 XP := X * Powten (Maxpow);
|
|
|
224 exit when XP >= Powten (S - 1) or else Scale < -Maxscaling;
|
|
|
225 X := XP;
|
|
|
226 Scale := Scale - Maxpow;
|
|
|
227 end loop;
|
|
|
228
|
|
|
229 -- The following exception is only raised in case of erroneous
|
|
|
230 -- execution, where a number was considered valid but still
|
|
|
231 -- fails to scale up. One situation where this can happen is
|
|
|
232 -- when a system which is supposed to be IEEE-compliant, but
|
|
|
233 -- has been reconfigured to flush denormals to zero.
|
|
|
234
|
|
|
235 if Scale < -Maxscaling then
|
|
|
236 raise Constraint_Error;
|
|
|
237 end if;
|
|
|
238
|
|
|
239 -- Here we know that we must multiply by at least 10**1 and that
|
|
|
240 -- 10**Maxpow takes us too far: binary search to find right one.
|
|
|
241
|
|
|
242 -- Because of roundoff errors, it is possible for the value
|
|
|
243 -- of XP to be just outside of the interval when Lo >= Hi. In
|
|
|
244 -- that case we adjust explicitly by a factor of 10. This
|
|
|
245 -- can only happen with a value that is very close to an
|
|
|
246 -- exact power of 10.
|
|
|
247
|
|
|
248 Lo := 1;
|
|
|
249 Hi := Maxpow;
|
|
|
250
|
|
|
251 loop
|
|
|
252 Mid := (Lo + Hi) / 2;
|
|
|
253 XP := X * Powten (Mid);
|
|
|
254
|
|
|
255 if XP < Powten (S - 1) then
|
|
|
256
|
|
|
257 if Lo >= Hi then
|
|
|
258 Mid := Mid + 1;
|
|
|
259 XP := XP * 10.0;
|
|
|
260 exit;
|
|
|
261
|
|
|
262 else
|
|
|
263 Lo := Mid + 1;
|
|
|
264 end if;
|
|
|
265
|
|
|
266 elsif XP >= Powten (S) then
|
|
|
267
|
|
|
268 if Lo >= Hi then
|
|
|
269 Mid := Mid - 1;
|
|
|
270 XP := XP / 10.0;
|
|
|
271 exit;
|
|
|
272
|
|
|
273 else
|
|
|
274 Hi := Mid - 1;
|
|
|
275 end if;
|
|
|
276
|
|
|
277 else
|
|
|
278 exit;
|
|
|
279 end if;
|
|
|
280 end loop;
|
|
|
281
|
|
|
282 X := XP;
|
|
|
283 Scale := Scale - Mid;
|
|
|
284
|
|
|
285 -- Cases where scaling down is required
|
|
|
286
|
|
|
287 elsif X >= Powten (S) then
|
|
|
288
|
|
|
289 -- What we are looking for is a power of ten to divide X by
|
|
|
290 -- so that the result lies within the required range.
|
|
|
291
|
|
|
292 loop
|
|
|
293 XP := X / Powten (Maxpow);
|
|
|
294 exit when XP < Powten (S) or else Scale > Maxscaling;
|
|
|
295 X := XP;
|
|
|
296 Scale := Scale + Maxpow;
|
|
|
297 end loop;
|
|
|
298
|
|
|
299 -- The following exception is only raised in case of erroneous
|
|
|
300 -- execution, where a number was considered valid but still
|
|
|
301 -- fails to scale up. One situation where this can happen is
|
|
|
302 -- when a system which is supposed to be IEEE-compliant, but
|
|
|
303 -- has been reconfigured to flush denormals to zero.
|
|
|
304
|
|
|
305 if Scale > Maxscaling then
|
|
|
306 raise Constraint_Error;
|
|
|
307 end if;
|
|
|
308
|
|
|
309 -- Here we know that we must divide by at least 10**1 and that
|
|
|
310 -- 10**Maxpow takes us too far, binary search to find right one.
|
|
|
311
|
|
|
312 Lo := 1;
|
|
|
313 Hi := Maxpow;
|
|
|
314
|
|
|
315 loop
|
|
|
316 Mid := (Lo + Hi) / 2;
|
|
|
317 XP := X / Powten (Mid);
|
|
|
318
|
|
|
319 if XP < Powten (S - 1) then
|
|
|
320
|
|
|
321 if Lo >= Hi then
|
|
|
322 XP := XP * 10.0;
|
|
|
323 Mid := Mid - 1;
|
|
|
324 exit;
|
|
|
325
|
|
|
326 else
|
|
|
327 Hi := Mid - 1;
|
|
|
328 end if;
|
|
|
329
|
|
|
330 elsif XP >= Powten (S) then
|
|
|
331
|
|
|
332 if Lo >= Hi then
|
|
|
333 XP := XP / 10.0;
|
|
|
334 Mid := Mid + 1;
|
|
|
335 exit;
|
|
|
336
|
|
|
337 else
|
|
|
338 Lo := Mid + 1;
|
|
|
339 end if;
|
|
|
340
|
|
|
341 else
|
|
|
342 exit;
|
|
|
343 end if;
|
|
|
344 end loop;
|
|
|
345
|
|
|
346 X := XP;
|
|
|
347 Scale := Scale + Mid;
|
|
|
348
|
|
|
349 -- Here we are already scaled right
|
|
|
350
|
|
|
351 else
|
|
|
352 null;
|
|
|
353 end if;
|
|
|
354
|
|
|
355 -- Round, readjusting scale if needed. Note that if a readjustment
|
|
|
356 -- occurs, then it is never necessary to round again, because there
|
|
|
357 -- is no possibility of such a second rounding causing a change.
|
|
|
358
|
|
|
359 X := X + 0.5;
|
|
|
360
|
|
|
361 if X >= Powten (S) then
|
|
|
362 X := X / 10.0;
|
|
|
363 Scale := Scale + 1;
|
|
|
364 end if;
|
|
|
365
|
|
|
366 end Adjust_Scale;
|
|
|
367
|
|
|
368 ---------------------
|
|
|
369 -- Convert_Integer --
|
|
|
370 ---------------------
|
|
|
371
|
|
|
372 procedure Convert_Integer is
|
|
|
373 begin
|
|
|
374 -- Use Unsigned routine if possible, since on many machines it will
|
|
|
375 -- be significantly more efficient than the Long_Long_Unsigned one.
|
|
|
376
|
|
|
377 if X < Powten (Unsdigs) then
|
|
|
378 Ndigs := 0;
|
|
|
379 Set_Image_Unsigned
|
|
|
380 (Unsigned (Long_Long_Float'Truncation (X)),
|
|
|
381 Digs, Ndigs);
|
|
|
382
|
|
|
383 -- But if we want more digits than fit in Unsigned, we have to use
|
|
|
384 -- the Long_Long_Unsigned routine after all.
|
|
|
385
|
|
|
386 else
|
|
|
387 Ndigs := 0;
|
|
|
388 Set_Image_Long_Long_Unsigned
|
|
|
389 (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
|
|
|
390 Digs, Ndigs);
|
|
|
391 end if;
|
|
|
392 end Convert_Integer;
|
|
|
393
|
|
|
394 ---------
|
|
|
395 -- Set --
|
|
|
396 ---------
|
|
|
397
|
|
|
398 procedure Set (C : Character) is
|
|
|
399 begin
|
|
|
400 P := P + 1;
|
|
|
401 S (P) := C;
|
|
|
402 end Set;
|
|
|
403
|
|
|
404 -------------------------
|
|
|
405 -- Set_Blanks_And_Sign --
|
|
|
406 -------------------------
|
|
|
407
|
|
|
408 procedure Set_Blanks_And_Sign (N : Integer) is
|
|
|
409 begin
|
|
|
410 if Sign = '-' then
|
|
|
411 for J in 1 .. N - 1 loop
|
|
|
412 Set (' ');
|
|
|
413 end loop;
|
|
|
414
|
|
|
415 Set ('-');
|
|
|
416
|
|
|
417 else
|
|
|
418 for J in 1 .. N loop
|
|
|
419 Set (' ');
|
|
|
420 end loop;
|
|
|
421 end if;
|
|
|
422 end Set_Blanks_And_Sign;
|
|
|
423
|
|
|
424 --------------
|
|
|
425 -- Set_Digs --
|
|
|
426 --------------
|
|
|
427
|
|
|
428 procedure Set_Digs (S, E : Natural) is
|
|
|
429 begin
|
|
|
430 for J in S .. E loop
|
|
|
431 Set (Digs (J));
|
|
|
432 end loop;
|
|
|
433 end Set_Digs;
|
|
|
434
|
|
|
435 ----------------------
|
|
|
436 -- Set_Special_Fill --
|
|
|
437 ----------------------
|
|
|
438
|
|
|
439 procedure Set_Special_Fill (N : Natural) is
|
|
|
440 F : Natural;
|
|
|
441
|
|
|
442 begin
|
|
|
443 F := Fore + 1 + Aft - N;
|
|
|
444
|
|
|
445 if Exp /= 0 then
|
|
|
446 F := F + Exp + 1;
|
|
|
447 end if;
|
|
|
448
|
|
|
449 for J in 1 .. F loop
|
|
|
450 Set ('*');
|
|
|
451 end loop;
|
|
|
452 end Set_Special_Fill;
|
|
|
453
|
|
|
454 ---------------
|
|
|
455 -- Set_Zeros --
|
|
|
456 ---------------
|
|
|
457
|
|
|
458 procedure Set_Zeros (N : Integer) is
|
|
|
459 begin
|
|
|
460 for J in 1 .. N loop
|
|
|
461 Set ('0');
|
|
|
462 end loop;
|
|
|
463 end Set_Zeros;
|
|
|
464
|
|
|
465 -- Start of processing for Set_Image_Real
|
|
|
466
|
|
|
467 begin
|
|
|
468 -- We call the floating-point processor reset routine so that we can
|
|
|
469 -- be sure the floating-point processor is properly set for conversion
|
|
|
470 -- calls. This is notably need on Windows, where calls to the operating
|
|
|
471 -- system randomly reset the processor into 64-bit mode.
|
|
|
472
|
|
|
473 System.Float_Control.Reset;
|
|
|
474
|
|
|
475 Scale := 0;
|
|
|
476
|
|
|
477 -- Deal with invalid values first,
|
|
|
478
|
|
|
479 if not V'Valid then
|
|
|
480
|
|
|
481 -- Note that we're taking our chances here, as V might be
|
|
|
482 -- an invalid bit pattern resulting from erroneous execution
|
|
|
483 -- (caused by using uninitialized variables for example).
|
|
|
484
|
|
|
485 -- No matter what, we'll at least get reasonable behavior,
|
|
|
486 -- converting to infinity or some other value, or causing an
|
|
|
487 -- exception to be raised is fine.
|
|
|
488
|
|
|
489 -- If the following test succeeds, then we definitely have
|
|
|
490 -- an infinite value, so we print Inf.
|
|
|
491
|
|
|
492 if V > Long_Long_Float'Last then
|
|
|
493 Set ('+');
|
|
|
494 Set ('I');
|
|
|
495 Set ('n');
|
|
|
496 Set ('f');
|
|
|
497 Set_Special_Fill (4);
|
|
|
498
|
|
|
499 -- In all other cases we print NaN
|
|
|
500
|
|
|
501 elsif V < Long_Long_Float'First then
|
|
|
502 Set ('-');
|
|
|
503 Set ('I');
|
|
|
504 Set ('n');
|
|
|
505 Set ('f');
|
|
|
506 Set_Special_Fill (4);
|
|
|
507
|
|
|
508 else
|
|
|
509 Set ('N');
|
|
|
510 Set ('a');
|
|
|
511 Set ('N');
|
|
|
512 Set_Special_Fill (3);
|
|
|
513 end if;
|
|
|
514
|
|
|
515 return;
|
|
|
516 end if;
|
|
|
517
|
|
|
518 -- Positive values
|
|
|
519
|
|
|
520 if V > 0.0 then
|
|
|
521 X := V;
|
|
|
522 Sign := '+';
|
|
|
523
|
|
|
524 -- Negative values
|
|
|
525
|
|
|
526 elsif V < 0.0 then
|
|
|
527 X := -V;
|
|
|
528 Sign := '-';
|
|
|
529
|
|
|
530 -- Zero values
|
|
|
531
|
|
|
532 elsif V = 0.0 then
|
|
|
533 if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
|
|
|
534 Sign := '-';
|
|
|
535 else
|
|
|
536 Sign := '+';
|
|
|
537 end if;
|
|
|
538
|
|
|
539 Set_Blanks_And_Sign (Fore - 1);
|
|
|
540 Set ('0');
|
|
|
541 Set ('.');
|
|
|
542 Set_Zeros (NFrac);
|
|
|
543
|
|
|
544 if Exp /= 0 then
|
|
|
545 Set ('E');
|
|
|
546 Set ('+');
|
|
|
547 Set_Zeros (Natural'Max (1, Exp - 1));
|
|
|
548 end if;
|
|
|
549
|
|
|
550 return;
|
|
|
551
|
|
|
552 else
|
|
|
553 -- It should not be possible for a NaN to end up here.
|
|
|
554 -- Either the 'Valid test has failed, or we have some form
|
|
|
555 -- of erroneous execution. Raise Constraint_Error instead of
|
|
|
556 -- attempting to go ahead printing the value.
|
|
|
557
|
|
|
558 raise Constraint_Error;
|
|
|
559 end if;
|
|
|
560
|
|
|
561 -- X and Sign are set here, and X is known to be a valid,
|
|
|
562 -- non-zero floating-point number.
|
|
|
563
|
|
|
564 -- Case of non-zero value with Exp = 0
|
|
|
565
|
|
|
566 if Exp = 0 then
|
|
|
567
|
|
|
568 -- First step is to multiply by 10 ** Nfrac to get an integer
|
|
|
569 -- value to be output, an then add 0.5 to round the result.
|
|
|
570
|
|
|
571 declare
|
|
|
572 NF : Natural := NFrac;
|
|
|
573
|
|
|
574 begin
|
|
|
575 loop
|
|
|
576 -- If we are larger than Powten (Maxdigs) now, then
|
|
|
577 -- we have too many significant digits, and we have
|
|
|
578 -- not even finished multiplying by NFrac (NF shows
|
|
|
579 -- the number of unaccounted-for digits).
|
|
|
580
|
|
|
581 if X >= Powten (Maxdigs) then
|
|
|
582
|
|
|
583 -- In this situation, we only to generate a reasonable
|
|
|
584 -- number of significant digits, and then zeroes after.
|
|
|
585 -- So first we rescale to get:
|
|
|
586
|
|
|
587 -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
|
|
|
588
|
|
|
589 -- and then convert the resulting integer
|
|
|
590
|
|
|
591 Adjust_Scale (Maxdigs);
|
|
|
592 Convert_Integer;
|
|
|
593
|
|
|
594 -- If that caused rescaling, then add zeros to the end
|
|
|
595 -- of the number to account for this scaling. Also add
|
|
|
596 -- zeroes to account for the undone multiplications
|
|
|
597
|
|
|
598 for J in 1 .. Scale + NF loop
|
|
|
599 Ndigs := Ndigs + 1;
|
|
|
600 Digs (Ndigs) := '0';
|
|
|
601 end loop;
|
|
|
602
|
|
|
603 exit;
|
|
|
604
|
|
|
605 -- If multiplication is complete, then convert the resulting
|
|
|
606 -- integer after rounding (note that X is non-negative)
|
|
|
607
|
|
|
608 elsif NF = 0 then
|
|
|
609 X := X + 0.5;
|
|
|
610 Convert_Integer;
|
|
|
611 exit;
|
|
|
612
|
|
|
613 -- Otherwise we can go ahead with the multiplication. If it
|
|
|
614 -- can be done in one step, then do it in one step.
|
|
|
615
|
|
|
616 elsif NF < Maxpow then
|
|
|
617 X := X * Powten (NF);
|
|
|
618 NF := 0;
|
|
|
619
|
|
|
620 -- If it cannot be done in one step, then do partial scaling
|
|
|
621
|
|
|
622 else
|
|
|
623 X := X * Powten (Maxpow);
|
|
|
624 NF := NF - Maxpow;
|
|
|
625 end if;
|
|
|
626 end loop;
|
|
|
627 end;
|
|
|
628
|
|
|
629 -- If number of available digits is less or equal to NFrac,
|
|
|
630 -- then we need an extra zero before the decimal point.
|
|
|
631
|
|
|
632 if Ndigs <= NFrac then
|
|
|
633 Set_Blanks_And_Sign (Fore - 1);
|
|
|
634 Set ('0');
|
|
|
635 Set ('.');
|
|
|
636 Set_Zeros (NFrac - Ndigs);
|
|
|
637 Set_Digs (1, Ndigs);
|
|
|
638
|
|
|
639 -- Normal case with some digits before the decimal point
|
|
|
640
|
|
|
641 else
|
|
|
642 Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
|
|
|
643 Set_Digs (1, Ndigs - NFrac);
|
|
|
644 Set ('.');
|
|
|
645 Set_Digs (Ndigs - NFrac + 1, Ndigs);
|
|
|
646 end if;
|
|
|
647
|
|
|
648 -- Case of non-zero value with non-zero Exp value
|
|
|
649
|
|
|
650 else
|
|
|
651 -- If NFrac is less than Maxdigs, then all the fraction digits are
|
|
|
652 -- significant, so we can scale the resulting integer accordingly.
|
|
|
653
|
|
|
654 if NFrac < Maxdigs then
|
|
|
655 Adjust_Scale (NFrac + 1);
|
|
|
656 Convert_Integer;
|
|
|
657
|
|
|
658 -- Otherwise, we get the maximum number of digits available
|
|
|
659
|
|
|
660 else
|
|
|
661 Adjust_Scale (Maxdigs);
|
|
|
662 Convert_Integer;
|
|
|
663
|
|
|
664 for J in 1 .. NFrac - Maxdigs + 1 loop
|
|
|
665 Ndigs := Ndigs + 1;
|
|
|
666 Digs (Ndigs) := '0';
|
|
|
667 Scale := Scale - 1;
|
|
|
668 end loop;
|
|
|
669 end if;
|
|
|
670
|
|
|
671 Set_Blanks_And_Sign (Fore - 1);
|
|
|
672 Set (Digs (1));
|
|
|
673 Set ('.');
|
|
|
674 Set_Digs (2, Ndigs);
|
|
|
675
|
|
|
676 -- The exponent is the scaling factor adjusted for the digits
|
|
|
677 -- that we output after the decimal point, since these were
|
|
|
678 -- included in the scaled digits that we output.
|
|
|
679
|
|
|
680 Expon := Scale + NFrac;
|
|
|
681
|
|
|
682 Set ('E');
|
|
|
683 Ndigs := 0;
|
|
|
684
|
|
|
685 if Expon >= 0 then
|
|
|
686 Set ('+');
|
|
|
687 Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
|
|
|
688 else
|
|
|
689 Set ('-');
|
|
|
690 Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
|
|
|
691 end if;
|
|
|
692
|
|
|
693 Set_Zeros (Exp - Ndigs - 1);
|
|
|
694 Set_Digs (1, Ndigs);
|
|
|
695 end if;
|
|
|
696
|
|
|
697 end Set_Image_Real;
|
|
|
698
|
|
|
699 end System.Img_Real;
|
