path: root/gcc/ada/libgnat/s-imager.adb

------------------------------------------------------------------------------
--                                                                          --
--                        GNAT RUN-TIME COMPONENTS                          --
--                                                                          --
--                       S Y S T E M . I M A G E _ R                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2023, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with System.Double_Real;
with System.Float_Control;
with System.Img_Util; use System.Img_Util;

package body System.Image_R is

   --  The following defines the maximum number of digits that we can convert
   --  accurately. This is limited by the precision of the Num type, and also
   --  by the number of digits that can be held in the Uns type, which is the
   --  integer type we use as an intermediate in the computation. But, in both
   --  cases, we can work with a double value in these types.

   --  Note that in the following, the "-2" accounts for the space and one
   --  extra digit, since we need the maximum number of 9's that can be
   --  represented, e.g. for the 64-bit case, Long_Long_Unsigned'Width is
   --  21, since the maximum value (approx 1.8E+19) has 20 digits, but the
   --  maximum number of 9's that can be represented is only 19.

   Maxdigs : constant Natural := 2 * Natural'Min (Uns'Width - 2, Num'Digits);

   Maxscaling : constant := 5000;
   --  Max decimal scaling required during conversion of floating-point
   --  numbers to decimal. This is used to defend against infinite
   --  looping in the conversion, as can be caused by erroneous executions.
   --  The largest exponent used on any current system is 2**16383, which
   --  is approximately 10**4932, and the highest number of decimal digits
   --  is about 35 for 128-bit floating-point formats, so 5000 leaves
   --  enough room for scaling such values

   package Double_Real is new System.Double_Real (Num);
   use type Double_Real.Double_T;

   subtype Double_T is Double_Real.Double_T;
   --  The double floating-point type

   function From_Unsigned is new Double_Real.From_Unsigned (Uns);
   function To_Unsigned is new Double_Real.To_Unsigned (Uns);
   --  Convert betwwen a double Num and a single Uns

   function Is_Negative (V : Num) return Boolean;
   --  Return True if V is negative for the purpose of the output, i.e. return
   --  True for negative zeros only if Signed_Zeros is True.

   -----------------------
   -- Image_Fixed_Point --
   -----------------------

   procedure Image_Fixed_Point
     (V   : Num;
      S   : in out String;
      P   : out Natural;
      Aft : Natural)
   is
      pragma Assert (S'First = 1);

   begin
      --  Output space at start if non-negative

      if V >= 0.0 then
         S (1) := ' ';
         P := 1;
      else
         P := 0;
      end if;

      Set_Image_Real (V, S, P, 1, Aft, 0);
   end Image_Fixed_Point;

   --------------------------
   -- Image_Floating_Point --
   --------------------------

   procedure Image_Floating_Point
     (V    : Num;
      S    : in out String;
      P    : out Natural;
      Digs : Natural)
   is
      pragma Assert (S'First = 1);

   begin
      --  Decide whether a blank should be prepended before the call to
      --  Set_Image_Real. We generate a blank for positive values, and
      --  also for positive zeros. For negative zeros, we generate a
      --  blank only if Signed_Zeros is False (the RM only permits the
      --  output of -0.0 when Signed_Zeros is True). We do not generate
      --  a blank for positive infinity, since we output an explicit +.

      if not Is_Negative (V) and then V <= Num'Last then
         pragma Annotate (CodePeer, False_Positive, "condition predetermined",
                          "CodePeer analysis ignores NaN and Inf values");
         pragma Assert (S'Last > 1);
         --  The caller is responsible for S to be large enough for all
         --  Image_Floating_Point operation.
         S (1) := ' ';
         P := 1;
      else
         P := 0;
      end if;

      Set_Image_Real (V, S, P, 1, Digs - 1, 3);
   end Image_Floating_Point;

   -----------------
   -- Is_Negative --
   -----------------

   function Is_Negative (V : Num) return Boolean is
   begin
      if V < 0.0 then
         return True;

      elsif V > 0.0 then
         return False;

      elsif not Num'Signed_Zeros then
         return False;

      else
         return Num'Copy_Sign (1.0, V) < 0.0;
      end if;
   end Is_Negative;

   --------------------
   -- Set_Image_Real --
   --------------------

   procedure Set_Image_Real
     (V    : Num;
      S    : in out String;
      P    : in out Natural;
      Fore : Natural;
      Aft  : Natural;
      Exp  : Natural)
   is
      Powten : constant array (0 .. Maxpow) of Double_T;
      pragma Import (Ada, Powten);
      for Powten'Address use Powten_Address;

      NFrac : constant Natural := Natural'Max (Aft, 1);
      --  Number of digits after the decimal point

      Digs : String (1 .. 3 + Maxdigs);
      --  Array used to hold digits of converted integer value

      Ndigs : Natural;
      --  Number of digits stored in Digs (and also subscript of last digit)

      Scale : Integer := 0;
      --  Exponent such that the result is Digs (1 .. NDigs) * 10**(-Scale)

      X : Double_T;
      --  Current absolute value of the input after scaling

      procedure Adjust_Scale (S : Natural);
      --  Adjusts the value in X by multiplying or dividing by a power of
      --  ten so that it is in the range 10**(S-1) <= X < 10**S. Scale is
      --  adjusted to reflect the power of ten used to divide the result,
      --  i.e. one is added to the scale value for each multiplication by
      --  10.0 and one is subtracted for each division by 10.0.

      ------------------
      -- Adjust_Scale --
      ------------------

      procedure Adjust_Scale (S : Natural) is
         Lo, Mid, Hi : Natural;
         XP : Double_T;

      begin
         --  Cases where scaling up is required

         if X < Powten (S - 1) then

            --  What we are looking for is a power of ten to multiply X by
            --  so that the result lies within the required range.

            loop
               XP := X * Powten (Maxpow);
               exit when XP >= Powten (S - 1) or else Scale > Maxscaling;
               X := XP;
               Scale := Scale + Maxpow;
            end loop;

            --  The following exception is only raised in case of erroneous
            --  execution, where a number was considered valid but still
            --  fails to scale up. One situation where this can happen is
            --  when a system which is supposed to be IEEE-compliant, but
            --  has been reconfigured to flush denormals to zero.

            if Scale > Maxscaling then
               raise Constraint_Error;
            end if;

            --  Here we know that we must multiply by at least 10**1 and that
            --  10**Maxpow takes us too far: binary search to find right one.

            --  Because of roundoff errors, it is possible for the value
            --  of XP to be just outside of the interval when Lo >= Hi. In
            --  that case we adjust explicitly by a factor of 10. This
            --  can only happen with a value that is very close to an
            --  exact power of 10.

            Lo := 1;
            Hi := Maxpow;

            loop
               Mid := (Lo + Hi) / 2;
               XP := X * Powten (Mid);

               if XP < Powten (S - 1) then

                  if Lo >= Hi then
                     Mid := Mid + 1;
                     XP := XP * 10.0;
                     exit;

                  else
                     Lo := Mid + 1;
                  end if;

               elsif XP >= Powten (S) then

                  if Lo >= Hi then
                     Mid := Mid - 1;
                     XP := XP / 10.0;
                     exit;

                  else
                     Hi := Mid - 1;
                  end if;

               else
                  exit;
               end if;
            end loop;

            X := XP;
            Scale := Scale + Mid;

         --  Cases where scaling down is required

         elsif X >= Powten (S) then

            --  What we are looking for is a power of ten to divide X by
            --  so that the result lies within the required range.

            loop
               XP := X / Powten (Maxpow);
               exit when XP < Powten (S) or else Scale < -Maxscaling;
               X := XP;
               Scale := Scale - Maxpow;
            end loop;

            --  The following exception is only raised in case of erroneous
            --  execution, where a number was considered valid but still
            --  fails to scale up. One situation where this can happen is
            --  when a system which is supposed to be IEEE-compliant, but
            --  has been reconfigured to flush denormals to zero.

            if Scale < -Maxscaling then
               raise Constraint_Error;
            end if;

            --  Here we know that we must divide by at least 10**1 and that
            --  10**Maxpow takes us too far, binary search to find right one.

            Lo := 1;
            Hi := Maxpow;

            loop
               Mid := (Lo + Hi) / 2;
               XP := X / Powten (Mid);

               if XP < Powten (S - 1) then

                  if Lo >= Hi then
                     XP := XP * 10.0;
                     Mid := Mid - 1;
                     exit;

                  else
                     Hi := Mid - 1;
                  end if;

               elsif XP >= Powten (S) then

                  if Lo >= Hi then
                     XP := XP / 10.0;
                     Mid := Mid + 1;
                     exit;

                  else
                     Lo := Mid + 1;
                  end if;

               else
                  exit;
               end if;
            end loop;

            X := XP;
            Scale := Scale - Mid;

         --  Here we are already scaled right

         else
            null;
         end if;
      end Adjust_Scale;

   --  Start of processing for Set_Image_Real

   begin
      --  We call the floating-point processor reset routine so we can be sure
      --  that the processor is properly set for conversions. This is notably
      --  needed on Windows, where calls to the operating system randomly reset
      --  the processor into 64-bit mode.

      if Num'Machine_Mantissa = 64 then
         System.Float_Control.Reset;
      end if;

      --  Deal with invalid values first

      if not V'Valid then

         --  Note that we're taking our chances here, as V might be
         --  an invalid bit pattern resulting from erroneous execution
         --  (caused by using uninitialized variables for example).

         --  No matter what, we'll at least get reasonable behavior,
         --  converting to infinity or some other value, or causing an
         --  exception to be raised is fine.

         --  If the following two tests succeed, then we definitely have
         --  an infinite value, so we print +Inf or -Inf.

         if V > Num'Last then
            pragma Annotate (CodePeer, False_Positive, "dead code",
                             "CodePeer analysis ignores NaN and Inf values");
            pragma Annotate (CodePeer, False_Positive, "test always true",
                             "CodePeer analysis ignores NaN and Inf values");

            Set_Floating_Invalid_Value (Infinity, S, P, Fore, Aft, Exp);

         elsif V < Num'First then
            Set_Floating_Invalid_Value (Minus_Infinity, S, P, Fore, Aft, Exp);

         --  In all other cases we print NaN

         else
            Set_Floating_Invalid_Value (Not_A_Number, S, P, Fore, Aft, Exp);
         end if;

         return;
      end if;

      --  Set the first character like Image

      Digs (1) := (if Is_Negative (V) then '-' else ' ');
      Ndigs := 1;

      X := Double_Real.To_Double (abs (V));

      --  If X is zero, we are done

      if X = 0.0 then
         Digs (2) := '0';
         Ndigs := 2;

      --  Otherwise, scale X and convert it to an integer

      else
         --  In exponent notation, we need exactly NFrac + 1 digits and always
         --  round the last one.

         if Exp > 0 then
            Adjust_Scale (Natural'Min (NFrac + 1, Maxdigs));
            X := X + 0.5;

         --  In straight notation, we compute the maximum number of digits and
         --  compare how many of them will be put after the decimal point with
         --  Nfrac, in order to find out whether we need to round the last one
         --  here or whether the rounding is performed by Set_Decimal_Digits.

         else
            Adjust_Scale (Maxdigs);
            if Scale <= NFrac then
               X := X + 0.5;
            end if;
         end if;

         --  If X fits in an Uns, do the conversion directly. Note that this is
         --  always the case for the Image attribute.

         if X <= Num (Uns'Last) then
            Set_Image_Unsigned (To_Unsigned (X), Digs, Ndigs);

         --  Otherwise, do the conversion in two steps

         else pragma Assert (X <= 10.0 ** Num'Digits * Num (Uns'Last));
            declare
               Y : constant Uns := To_Unsigned (X / Powten (Num'Digits));

               Buf : String (1 .. Num'Digits);
               Len : Natural;

            begin
               Set_Image_Unsigned (Y, Digs, Ndigs);

               X := X - From_Unsigned (Y) * Powten (Num'Digits);

               Len := 0;
               Set_Image_Unsigned (To_Unsigned (X), Buf, Len);

               for J in 1 .. Num'Digits - Len loop
                  Digs (Ndigs + J) := '0';
               end loop;

               for J in 1 .. Len loop
                  Digs (Ndigs + Num'Digits - Len + J) := Buf (J);
               end loop;

               Ndigs := Ndigs + Num'Digits;
            end;
         end if;
      end if;

      Set_Decimal_Digits (Digs, Ndigs, S, P, Scale, Fore, Aft, Exp);
   end Set_Image_Real;

end System.Image_R;