1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . I M G _ R E A L --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 with System.Img_LLU; use System.Img_LLU;
37 with System.Img_Uns; use System.Img_Uns;
38 with System.Powten_Table; use System.Powten_Table;
39 with System.Unsigned_Types; use System.Unsigned_Types;
41 package body System.Img_Real is
43 -- The following defines the maximum number of digits that we can convert
44 -- accurately. This is limited by the precision of Long_Long_Float, and
45 -- also by the number of digits we can hold in Long_Long_Unsigned, which
46 -- is the integer type we use as an intermediate for the result.
48 -- We assume that in practice, the limitation will come from the digits
49 -- value, rather than the integer value. This is true for typical IEEE
50 -- implementations, and at worst, the only loss is for some precision
51 -- in very high precision floating-point output.
53 -- Note that in the following, the "-2" accounts for the sign and one
54 -- extra digits, since we need the maximum number of 9's that can be
55 -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
56 -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
57 -- but the maximum number of 9's that can be supported is 19.
61 (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
63 Unsdigs : constant := Unsigned'Width - 2;
64 -- Number of digits that can be converted using type Unsigned
65 -- See above for the explanation of the -2.
67 Maxscaling : constant := 5000;
68 -- Max decimal scaling required during conversion of floating-point
69 -- numbers to decimal. This is used to defend against infinite
70 -- looping in the conversion, as can be caused by erroneous executions.
71 -- The largest exponent used on any current system is 2**16383, which
72 -- is approximately 10**4932, and the highest number of decimal digits
73 -- is about 35 for 128-bit floating-point formats, so 5000 leaves
74 -- enough room for scaling such values
76 function Is_Negative (V : Long_Long_Float) return Boolean;
77 pragma Import (Intrinsic, Is_Negative);
79 --------------------------
80 -- Image_Floating_Point --
81 --------------------------
83 function Image_Floating_Point
89 S : String (1 .. Long_Long_Float'Width);
92 if not Is_Negative (V) then
97 Set_Image_Real (V, S, P, 1, Digs - 1, 3);
99 end Image_Floating_Point;
101 --------------------------------
102 -- Image_Ordinary_Fixed_Point --
103 --------------------------------
105 function Image_Ordinary_Fixed_Point
106 (V : Long_Long_Float;
111 S : String (1 .. Long_Long_Float'Width);
119 Set_Image_Real (V, S, P, 1, Aft, 0);
121 end Image_Ordinary_Fixed_Point;
127 procedure Set_Image_Real
128 (V : Long_Long_Float;
136 pragma Import (C, Reset, "__gnat_init_float");
137 -- We import the floating-point processor reset routine so that we can
138 -- be sure the floating-point processor is properly set for conversion
139 -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads).
140 -- This is notably need on Windows, where calls to the operating system
141 -- randomly reset the processor into 64-bit mode.
143 NFrac : constant Natural := Natural'Max (Aft, 1);
145 X : aliased Long_Long_Float;
146 -- This is declared aliased because the expansion of X'Valid passes
147 -- X by access and JGNAT requires all access parameters to be aliased.
148 -- The Valid attribute probably needs to be handled via a different
149 -- expansion for JGNAT, and this use of aliased should be removed
150 -- once Valid is handled properly. ???
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!
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.
164 -- Number of digits stored in Digs (and also subscript of last digit)
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).
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),
180 procedure Set (C : Character);
181 -- Sets character C in output buffer
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).
189 procedure Set_Digs (S, E : Natural);
190 -- Set digits S through E from Digs buffer. No effect if S > E
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)
197 procedure Set_Zeros (N : Integer);
198 -- Set N zeros, no effect if N is negative
201 pragma Inline (Set_Digs);
202 pragma Inline (Set_Zeros);
208 procedure Adjust_Scale (S : Natural) is
212 XP : Long_Long_Float;
215 -- Cases where scaling up is required
217 if X < Powten (S - 1) then
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.
223 XP := X * Powten (Maxpow);
224 exit when XP >= Powten (S - 1) or Scale < -Maxscaling;
226 Scale := Scale - Maxpow;
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.
235 if Scale < -Maxscaling then
236 raise Constraint_Error;
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.
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.
252 Mid := (Lo + Hi) / 2;
253 XP := X * Powten (Mid);
255 if XP < Powten (S - 1) then
266 elsif XP >= Powten (S) then
283 Scale := Scale - Mid;
285 -- Cases where scaling down is required
287 elsif X >= Powten (S) then
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.
293 XP := X / Powten (Maxpow);
294 exit when XP < Powten (S) or Scale > Maxscaling;
296 Scale := Scale + Maxpow;
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.
305 if Scale > Maxscaling then
306 raise Constraint_Error;
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.
316 Mid := (Lo + Hi) / 2;
317 XP := X / Powten (Mid);
319 if XP < Powten (S - 1) then
330 elsif XP >= Powten (S) then
347 Scale := Scale + Mid;
349 -- Here we are already scaled right
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.
361 if X >= Powten (S) then
368 ---------------------
369 -- Convert_Integer --
370 ---------------------
372 procedure Convert_Integer is
374 -- Use Unsigned routine if possible, since on many machines it will
375 -- be significantly more efficient than the Long_Long_Unsigned one.
377 if X < Powten (Unsdigs) then
380 (Unsigned (Long_Long_Float'Truncation (X)),
383 -- But if we want more digits than fit in Unsigned, we have to use
384 -- the Long_Long_Unsigned routine after all.
388 Set_Image_Long_Long_Unsigned
389 (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
398 procedure Set (C : Character) is
404 -------------------------
405 -- Set_Blanks_And_Sign --
406 -------------------------
408 procedure Set_Blanks_And_Sign (N : Integer) is
411 for J in 1 .. N - 1 loop
422 end Set_Blanks_And_Sign;
428 procedure Set_Digs (S, E : Natural) is
435 ----------------------
436 -- Set_Special_Fill --
437 ----------------------
439 procedure Set_Special_Fill (N : Natural) is
443 F := Fore + 1 + Aft - N;
452 end Set_Special_Fill;
458 procedure Set_Zeros (N : Integer) is
465 -- Start of processing for Set_Image_Real
486 if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
492 Set_Blanks_And_Sign (Fore - 1);
500 Set_Zeros (Natural'Max (1, Exp - 1));
506 -- Deal with invalid values
510 -- Note that we're taking our chances here, as X might be
511 -- an invalid bit pattern resulting from erroneous execution
512 -- (caused by using uninitialized variables for example).
514 -- No matter what, we'll at least get reasonable behaviour,
515 -- converting to infinity or some other value, or causing an
516 -- exception to be raised is fine.
518 -- If the following test succeeds, then we definitely have
519 -- an infinite value, so we print Inf.
521 if X > Long_Long_Float'Last then
526 Set_Special_Fill (4);
528 -- In all other cases we print NaN
534 Set_Special_Fill (3);
539 -- Case of non-zero value with Exp = 0
543 -- First step is to multiply by 10 ** Nfrac to get an integer
544 -- value to be output, an then add 0.5 to round the result.
547 NF : Natural := NFrac;
551 -- If we are larger than Powten (Maxdigs) now, then
552 -- we have too many significant digits, and we have
553 -- not even finished multiplying by NFrac (NF shows
554 -- the number of unaccounted-for digits).
556 if X >= Powten (Maxdigs) then
558 -- In this situation, we only to generate a reasonable
559 -- number of significant digits, and then zeroes after.
560 -- So first we rescale to get:
562 -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
564 -- and then convert the resulting integer
566 Adjust_Scale (Maxdigs);
569 -- If that caused rescaling, then add zeros to the end
570 -- of the number to account for this scaling. Also add
571 -- zeroes to account for the undone multiplications
573 for J in 1 .. Scale + NF loop
580 -- If multiplication is complete, then convert the resulting
581 -- integer after rounding (note that X is non-negative)
588 -- Otherwise we can go ahead with the multiplication. If it
589 -- can be done in one step, then do it in one step.
591 elsif NF < Maxpow then
592 X := X * Powten (NF);
595 -- If it cannot be done in one step, then do partial scaling
598 X := X * Powten (Maxpow);
604 -- If number of available digits is less or equal to NFrac,
605 -- then we need an extra zero before the decimal point.
607 if Ndigs <= NFrac then
608 Set_Blanks_And_Sign (Fore - 1);
611 Set_Zeros (NFrac - Ndigs);
614 -- Normal case with some digits before the decimal point
617 Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
618 Set_Digs (1, Ndigs - NFrac);
620 Set_Digs (Ndigs - NFrac + 1, Ndigs);
623 -- Case of non-zero value with non-zero Exp value
626 -- If NFrac is less than Maxdigs, then all the fraction digits are
627 -- significant, so we can scale the resulting integer accordingly.
629 if NFrac < Maxdigs then
630 Adjust_Scale (NFrac + 1);
633 -- Otherwise, we get the maximum number of digits available
636 Adjust_Scale (Maxdigs);
639 for J in 1 .. NFrac - Maxdigs + 1 loop
646 Set_Blanks_And_Sign (Fore - 1);
651 -- The exponent is the scaling factor adjusted for the digits
652 -- that we output after the decimal point, since these were
653 -- included in the scaled digits that we output.
655 Expon := Scale + NFrac;
662 Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
665 Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
668 Set_Zeros (Exp - Ndigs - 1);