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