Fix unused warnings.
[official-gcc/graphite-test-results.git] / gcc / ada / s-imgrea.adb
blob1415a8b80f66606c068a5ec1c61293697305657c
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 -- --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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 ------------------------------------------------------------------------------
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;
37 package body System.Img_Real is
39 -- The following defines the maximum number of digits that we can convert
40 -- accurately. This is limited by the precision of Long_Long_Float, and
41 -- also by the number of digits we can hold in Long_Long_Unsigned, which
42 -- is the integer type we use as an intermediate for the result.
44 -- We assume that in practice, the limitation will come from the digits
45 -- value, rather than the integer value. This is true for typical IEEE
46 -- implementations, and at worst, the only loss is for some precision
47 -- in very high precision floating-point output.
49 -- Note that in the following, the "-2" accounts for the sign and one
50 -- extra digits, since we need the maximum number of 9's that can be
51 -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width
52 -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits,
53 -- but the maximum number of 9's that can be supported is 19.
55 Maxdigs : constant :=
56 Natural'Min
57 (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits);
59 Unsdigs : constant := Unsigned'Width - 2;
60 -- Number of digits that can be converted using type Unsigned
61 -- See above for the explanation of the -2.
63 Maxscaling : constant := 5000;
64 -- Max decimal scaling required during conversion of floating-point
65 -- numbers to decimal. This is used to defend against infinite
66 -- looping in the conversion, as can be caused by erroneous executions.
67 -- The largest exponent used on any current system is 2**16383, which
68 -- is approximately 10**4932, and the highest number of decimal digits
69 -- is about 35 for 128-bit floating-point formats, so 5000 leaves
70 -- enough room for scaling such values
72 function Is_Negative (V : Long_Long_Float) return Boolean;
73 pragma Import (Intrinsic, Is_Negative);
75 --------------------------
76 -- Image_Floating_Point --
77 --------------------------
79 procedure Image_Floating_Point
80 (V : Long_Long_Float;
81 S : in out String;
82 P : out Natural;
83 Digs : Natural)
85 pragma Assert (S'First = 1);
87 begin
88 -- Decide whether a blank should be prepended before the call to
89 -- Set_Image_Real. We generate a blank for positive values, and
90 -- also for positive zeroes. For negative zeroes, we generate a
91 -- space only if Signed_Zeroes is True (the RM only permits the
92 -- output of -0.0 on targets where this is the case). We can of
93 -- course still see a -0.0 on a target where Signed_Zeroes is
94 -- False (since this attribute refers to the proper handling of
95 -- negative zeroes, not to their existence).
97 if not Is_Negative (V)
98 or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
99 then
100 S (1) := ' ';
101 P := 1;
102 else
103 P := 0;
104 end if;
106 Set_Image_Real (V, S, P, 1, Digs - 1, 3);
107 end Image_Floating_Point;
109 --------------------------------
110 -- Image_Ordinary_Fixed_Point --
111 --------------------------------
113 procedure Image_Ordinary_Fixed_Point
114 (V : Long_Long_Float;
115 S : in out String;
116 P : out Natural;
117 Aft : Natural)
119 pragma Assert (S'First = 1);
121 begin
122 -- Output space at start if non-negative
124 if V >= 0.0 then
125 S (1) := ' ';
126 P := 1;
127 else
128 P := 0;
129 end if;
131 Set_Image_Real (V, S, P, 1, Aft, 0);
132 end Image_Ordinary_Fixed_Point;
134 --------------------
135 -- Set_Image_Real --
136 --------------------
138 procedure Set_Image_Real
139 (V : Long_Long_Float;
140 S : out String;
141 P : in out Natural;
142 Fore : Natural;
143 Aft : Natural;
144 Exp : Natural)
146 procedure Reset;
147 pragma Import (C, Reset, "__gnat_init_float");
148 -- We import the floating-point processor reset routine so that we can
149 -- be sure the floating-point processor is properly set for conversion
150 -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads).
151 -- This is notably need on Windows, where calls to the operating system
152 -- randomly reset the processor into 64-bit mode.
154 NFrac : constant Natural := Natural'Max (Aft, 1);
155 Sign : Character;
156 X : aliased Long_Long_Float;
157 -- This is declared aliased because the expansion of X'Valid passes
158 -- X by access and JGNAT requires all access parameters to be aliased.
159 -- The Valid attribute probably needs to be handled via a different
160 -- expansion for JGNAT, and this use of aliased should be removed
161 -- once Valid is handled properly. ???
162 Scale : Integer;
163 Expon : Integer;
165 Field_Max : constant := 255;
166 -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last.
167 -- It is not worth dragging in Ada.Text_IO to pick up this value,
168 -- since it really should never be necessary to change it!
170 Digs : String (1 .. 2 * Field_Max + 16);
171 -- Array used to hold digits of converted integer value. This is a
172 -- large enough buffer to accommodate ludicrous values of Fore and Aft.
174 Ndigs : Natural;
175 -- Number of digits stored in Digs (and also subscript of last digit)
177 procedure Adjust_Scale (S : Natural);
178 -- Adjusts the value in X by multiplying or dividing by a power of
179 -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes
180 -- adding 0.5 to round the result, readjusting if the rounding causes
181 -- the result to wander out of the range. Scale is adjusted to reflect
182 -- the power of ten used to divide the result (i.e. one is added to
183 -- the scale value for each division by 10.0, or one is subtracted
184 -- for each multiplication by 10.0).
186 procedure Convert_Integer;
187 -- Takes the value in X, outputs integer digits into Digs. On return,
188 -- Ndigs is set to the number of digits stored. The digits are stored
189 -- in Digs (1 .. Ndigs),
191 procedure Set (C : Character);
192 -- Sets character C in output buffer
194 procedure Set_Blanks_And_Sign (N : Integer);
195 -- Sets leading blanks and minus sign if needed. N is the number of
196 -- positions to be filled (a minus sign is output even if N is zero
197 -- or negative, but for a positive value, if N is non-positive, then
198 -- the call has no effect).
200 procedure Set_Digs (S, E : Natural);
201 -- Set digits S through E from Digs buffer. No effect if S > E
203 procedure Set_Special_Fill (N : Natural);
204 -- After outputting +Inf, -Inf or NaN, this routine fills out the
205 -- rest of the field with * characters. The argument is the number
206 -- of characters output so far (either 3 or 4)
208 procedure Set_Zeros (N : Integer);
209 -- Set N zeros, no effect if N is negative
211 pragma Inline (Set);
212 pragma Inline (Set_Digs);
213 pragma Inline (Set_Zeros);
215 ------------------
216 -- Adjust_Scale --
217 ------------------
219 procedure Adjust_Scale (S : Natural) is
220 Lo : Natural;
221 Hi : Natural;
222 Mid : Natural;
223 XP : Long_Long_Float;
225 begin
226 -- Cases where scaling up is required
228 if X < Powten (S - 1) then
230 -- What we are looking for is a power of ten to multiply X by
231 -- so that the result lies within the required range.
233 loop
234 XP := X * Powten (Maxpow);
235 exit when XP >= Powten (S - 1) or else Scale < -Maxscaling;
236 X := XP;
237 Scale := Scale - Maxpow;
238 end loop;
240 -- The following exception is only raised in case of erroneous
241 -- execution, where a number was considered valid but still
242 -- fails to scale up. One situation where this can happen is
243 -- when a system which is supposed to be IEEE-compliant, but
244 -- has been reconfigured to flush denormals to zero.
246 if Scale < -Maxscaling then
247 raise Constraint_Error;
248 end if;
250 -- Here we know that we must multiply by at least 10**1 and that
251 -- 10**Maxpow takes us too far: binary search to find right one.
253 -- Because of roundoff errors, it is possible for the value
254 -- of XP to be just outside of the interval when Lo >= Hi. In
255 -- that case we adjust explicitly by a factor of 10. This
256 -- can only happen with a value that is very close to an
257 -- exact power of 10.
259 Lo := 1;
260 Hi := Maxpow;
262 loop
263 Mid := (Lo + Hi) / 2;
264 XP := X * Powten (Mid);
266 if XP < Powten (S - 1) then
268 if Lo >= Hi then
269 Mid := Mid + 1;
270 XP := XP * 10.0;
271 exit;
273 else
274 Lo := Mid + 1;
275 end if;
277 elsif XP >= Powten (S) then
279 if Lo >= Hi then
280 Mid := Mid - 1;
281 XP := XP / 10.0;
282 exit;
284 else
285 Hi := Mid - 1;
286 end if;
288 else
289 exit;
290 end if;
291 end loop;
293 X := XP;
294 Scale := Scale - Mid;
296 -- Cases where scaling down is required
298 elsif X >= Powten (S) then
300 -- What we are looking for is a power of ten to divide X by
301 -- so that the result lies within the required range.
303 loop
304 XP := X / Powten (Maxpow);
305 exit when XP < Powten (S) or else Scale > Maxscaling;
306 X := XP;
307 Scale := Scale + Maxpow;
308 end loop;
310 -- The following exception is only raised in case of erroneous
311 -- execution, where a number was considered valid but still
312 -- fails to scale up. One situation where this can happen is
313 -- when a system which is supposed to be IEEE-compliant, but
314 -- has been reconfigured to flush denormals to zero.
316 if Scale > Maxscaling then
317 raise Constraint_Error;
318 end if;
320 -- Here we know that we must divide by at least 10**1 and that
321 -- 10**Maxpow takes us too far, binary search to find right one.
323 Lo := 1;
324 Hi := Maxpow;
326 loop
327 Mid := (Lo + Hi) / 2;
328 XP := X / Powten (Mid);
330 if XP < Powten (S - 1) then
332 if Lo >= Hi then
333 XP := XP * 10.0;
334 Mid := Mid - 1;
335 exit;
337 else
338 Hi := Mid - 1;
339 end if;
341 elsif XP >= Powten (S) then
343 if Lo >= Hi then
344 XP := XP / 10.0;
345 Mid := Mid + 1;
346 exit;
348 else
349 Lo := Mid + 1;
350 end if;
352 else
353 exit;
354 end if;
355 end loop;
357 X := XP;
358 Scale := Scale + Mid;
360 -- Here we are already scaled right
362 else
363 null;
364 end if;
366 -- Round, readjusting scale if needed. Note that if a readjustment
367 -- occurs, then it is never necessary to round again, because there
368 -- is no possibility of such a second rounding causing a change.
370 X := X + 0.5;
372 if X >= Powten (S) then
373 X := X / 10.0;
374 Scale := Scale + 1;
375 end if;
377 end Adjust_Scale;
379 ---------------------
380 -- Convert_Integer --
381 ---------------------
383 procedure Convert_Integer is
384 begin
385 -- Use Unsigned routine if possible, since on many machines it will
386 -- be significantly more efficient than the Long_Long_Unsigned one.
388 if X < Powten (Unsdigs) then
389 Ndigs := 0;
390 Set_Image_Unsigned
391 (Unsigned (Long_Long_Float'Truncation (X)),
392 Digs, Ndigs);
394 -- But if we want more digits than fit in Unsigned, we have to use
395 -- the Long_Long_Unsigned routine after all.
397 else
398 Ndigs := 0;
399 Set_Image_Long_Long_Unsigned
400 (Long_Long_Unsigned (Long_Long_Float'Truncation (X)),
401 Digs, Ndigs);
402 end if;
403 end Convert_Integer;
405 ---------
406 -- Set --
407 ---------
409 procedure Set (C : Character) is
410 begin
411 P := P + 1;
412 S (P) := C;
413 end Set;
415 -------------------------
416 -- Set_Blanks_And_Sign --
417 -------------------------
419 procedure Set_Blanks_And_Sign (N : Integer) is
420 begin
421 if Sign = '-' then
422 for J in 1 .. N - 1 loop
423 Set (' ');
424 end loop;
426 Set ('-');
428 else
429 for J in 1 .. N loop
430 Set (' ');
431 end loop;
432 end if;
433 end Set_Blanks_And_Sign;
435 --------------
436 -- Set_Digs --
437 --------------
439 procedure Set_Digs (S, E : Natural) is
440 begin
441 for J in S .. E loop
442 Set (Digs (J));
443 end loop;
444 end Set_Digs;
446 ----------------------
447 -- Set_Special_Fill --
448 ----------------------
450 procedure Set_Special_Fill (N : Natural) is
451 F : Natural;
453 begin
454 F := Fore + 1 + Aft - N;
456 if Exp /= 0 then
457 F := F + Exp + 1;
458 end if;
460 for J in 1 .. F loop
461 Set ('*');
462 end loop;
463 end Set_Special_Fill;
465 ---------------
466 -- Set_Zeros --
467 ---------------
469 procedure Set_Zeros (N : Integer) is
470 begin
471 for J in 1 .. N loop
472 Set ('0');
473 end loop;
474 end Set_Zeros;
476 -- Start of processing for Set_Image_Real
478 begin
479 Reset;
480 Scale := 0;
482 -- Deal with invalid values first,
484 if not V'Valid then
486 -- Note that we're taking our chances here, as V might be
487 -- an invalid bit pattern resulting from erroneous execution
488 -- (caused by using uninitialized variables for example).
490 -- No matter what, we'll at least get reasonable behaviour,
491 -- converting to infinity or some other value, or causing an
492 -- exception to be raised is fine.
494 -- If the following test succeeds, then we definitely have
495 -- an infinite value, so we print Inf.
497 if V > Long_Long_Float'Last then
498 Set ('+');
499 Set ('I');
500 Set ('n');
501 Set ('f');
502 Set_Special_Fill (4);
504 -- In all other cases we print NaN
506 elsif V < Long_Long_Float'First then
507 Set ('-');
508 Set ('I');
509 Set ('n');
510 Set ('f');
511 Set_Special_Fill (4);
513 else
514 Set ('N');
515 Set ('a');
516 Set ('N');
517 Set_Special_Fill (3);
518 end if;
520 return;
521 end if;
523 -- Positive values
525 if V > 0.0 then
526 X := V;
527 Sign := '+';
529 -- Negative values
531 elsif V < 0.0 then
532 X := -V;
533 Sign := '-';
535 -- Zero values
537 elsif V = 0.0 then
538 if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then
539 Sign := '-';
540 else
541 Sign := '+';
542 end if;
544 Set_Blanks_And_Sign (Fore - 1);
545 Set ('0');
546 Set ('.');
547 Set_Zeros (NFrac);
549 if Exp /= 0 then
550 Set ('E');
551 Set ('+');
552 Set_Zeros (Natural'Max (1, Exp - 1));
553 end if;
555 return;
557 else
558 -- It should not be possible for a NaN to end up here.
559 -- Either the 'Valid test has failed, or we have some form
560 -- of erroneous execution. Raise Constraint_Error instead of
561 -- attempting to go ahead printing the value.
563 raise Constraint_Error;
564 end if;
566 -- X and Sign are set here, and X is known to be a valid,
567 -- non-zero floating-point number.
569 -- Case of non-zero value with Exp = 0
571 if Exp = 0 then
573 -- First step is to multiply by 10 ** Nfrac to get an integer
574 -- value to be output, an then add 0.5 to round the result.
576 declare
577 NF : Natural := NFrac;
579 begin
580 loop
581 -- If we are larger than Powten (Maxdigs) now, then
582 -- we have too many significant digits, and we have
583 -- not even finished multiplying by NFrac (NF shows
584 -- the number of unaccounted-for digits).
586 if X >= Powten (Maxdigs) then
588 -- In this situation, we only to generate a reasonable
589 -- number of significant digits, and then zeroes after.
590 -- So first we rescale to get:
592 -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs
594 -- and then convert the resulting integer
596 Adjust_Scale (Maxdigs);
597 Convert_Integer;
599 -- If that caused rescaling, then add zeros to the end
600 -- of the number to account for this scaling. Also add
601 -- zeroes to account for the undone multiplications
603 for J in 1 .. Scale + NF loop
604 Ndigs := Ndigs + 1;
605 Digs (Ndigs) := '0';
606 end loop;
608 exit;
610 -- If multiplication is complete, then convert the resulting
611 -- integer after rounding (note that X is non-negative)
613 elsif NF = 0 then
614 X := X + 0.5;
615 Convert_Integer;
616 exit;
618 -- Otherwise we can go ahead with the multiplication. If it
619 -- can be done in one step, then do it in one step.
621 elsif NF < Maxpow then
622 X := X * Powten (NF);
623 NF := 0;
625 -- If it cannot be done in one step, then do partial scaling
627 else
628 X := X * Powten (Maxpow);
629 NF := NF - Maxpow;
630 end if;
631 end loop;
632 end;
634 -- If number of available digits is less or equal to NFrac,
635 -- then we need an extra zero before the decimal point.
637 if Ndigs <= NFrac then
638 Set_Blanks_And_Sign (Fore - 1);
639 Set ('0');
640 Set ('.');
641 Set_Zeros (NFrac - Ndigs);
642 Set_Digs (1, Ndigs);
644 -- Normal case with some digits before the decimal point
646 else
647 Set_Blanks_And_Sign (Fore - (Ndigs - NFrac));
648 Set_Digs (1, Ndigs - NFrac);
649 Set ('.');
650 Set_Digs (Ndigs - NFrac + 1, Ndigs);
651 end if;
653 -- Case of non-zero value with non-zero Exp value
655 else
656 -- If NFrac is less than Maxdigs, then all the fraction digits are
657 -- significant, so we can scale the resulting integer accordingly.
659 if NFrac < Maxdigs then
660 Adjust_Scale (NFrac + 1);
661 Convert_Integer;
663 -- Otherwise, we get the maximum number of digits available
665 else
666 Adjust_Scale (Maxdigs);
667 Convert_Integer;
669 for J in 1 .. NFrac - Maxdigs + 1 loop
670 Ndigs := Ndigs + 1;
671 Digs (Ndigs) := '0';
672 Scale := Scale - 1;
673 end loop;
674 end if;
676 Set_Blanks_And_Sign (Fore - 1);
677 Set (Digs (1));
678 Set ('.');
679 Set_Digs (2, Ndigs);
681 -- The exponent is the scaling factor adjusted for the digits
682 -- that we output after the decimal point, since these were
683 -- included in the scaled digits that we output.
685 Expon := Scale + NFrac;
687 Set ('E');
688 Ndigs := 0;
690 if Expon >= 0 then
691 Set ('+');
692 Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs);
693 else
694 Set ('-');
695 Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs);
696 end if;
698 Set_Zeros (Exp - Ndigs - 1);
699 Set_Digs (1, Ndigs);
700 end if;
702 end Set_Image_Real;
704 end System.Img_Real;