File : s-imgrea.adb


   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-2015, 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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 behaviour,
 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;