s-imguti.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                      S Y S T E M . I M G _ U T I L                       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2020-2022, 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.Img_Uns; use System.Img_Uns;

package body System.Img_Util is

   ------------------------
   -- Set_Decimal_Digits --
   ------------------------

   procedure Set_Decimal_Digits
     (Digs  : in out String;
      NDigs : Natural;
      S     : out String;
      P     : in out Natural;
      Scale : Integer;
      Fore  : Natural;
      Aft   : Natural;
      Exp   : Natural)
   is
      pragma Assert (NDigs >= 1);
      pragma Assert (Digs'First = 1);
      pragma Assert (Digs'First < Digs'Last);

      Minus : constant Boolean := (Digs (Digs'First) = '-');
      --  Set True if input is negative

      Zero : Boolean := (Digs (Digs'First + 1) = '0');
      --  Set True if input is exactly zero (only case when a leading zero
      --  is permitted in the input string given to this procedure). This
      --  flag can get set later if rounding causes the value to become zero.

      FD : Natural := 2;
      --  First digit position of digits remaining to be processed

      LD : Natural := NDigs;
      --  Last digit position of digits remaining to be processed

      ND : Natural := NDigs - 1;
      --  Number of digits remaining to be processed (LD - FD + 1)

      Digits_Before_Point : Integer := ND - Scale;
      --  Number of digits before decimal point in the input value. This
      --  value can be negative if the input value is less than 0.1, so
      --  it is an indication of the current exponent. Digits_Before_Point
      --  is adjusted if the rounding step generates an extra digit.

      Digits_After_Point : constant Natural := Integer'Max (1, Aft);
      --  Digit positions after decimal point in result string

      Expon : Integer;
      --  Integer value of exponent

      procedure Round (N : Integer);
      --  Round the number in Digs. N is the position of the last digit to be
      --  retained in the rounded position (rounding is based on Digs (N + 1)
      --  FD, LD, ND are reset as necessary if required. Note that if the
      --  result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
      --  placed in the sign position as a result of the rounding, this is
      --  the case in which FD is adjusted. The call to Round has no effect
      --  if N is outside the range FD .. LD.

      procedure Set (C : Character);
      pragma Inline (Set);
      --  Sets character C in output buffer

      procedure Set_Blanks_And_Sign (N : Integer);
      --  Sets leading blanks and minus sign if needed. N is the number of
      --  positions to be filled (a minus sign is output even if N is zero
      --  or negative, but for a positive value, if N is non-positive, then
      --  the call has no effect).

      procedure Set_Digits (S, E : Natural);
      pragma Inline (Set_Digits);
      --  Set digits S through E from Digs, no effect if S > E

      procedure Set_Zeroes (N : Integer);
      pragma Inline (Set_Zeroes);
      --  Set N zeroes, no effect if N is negative

      -----------
      -- Round --
      -----------

      procedure Round (N : Integer) is
         D : Character;

         pragma Assert (NDigs >= 1);
         pragma Assert (Digs'First = 1);
         pragma Assert (Digs'First < Digs'Last);

      begin
         --  Nothing to do if rounding past the last digit we have

         if N >= LD then
            return;

         --  Cases of rounding before the initial digit

         elsif N < FD then

            --  The result is zero, unless we are rounding just before
            --  the first digit, and the first digit is five or more.

            if N = 1 and then Digs (Digs'First + 1) >= '5' then
               Digs (Digs'First) := '1';
            else
               Digs (Digs'First) := '0';
               Zero := True;
            end if;

            Digits_Before_Point := Digits_Before_Point + 1;
            FD := 1;
            LD := 1;
            ND := 1;

         --  Normal case of rounding an existing digit

         else
            LD := N;
            pragma Assert (LD >= 1);
            --  In this case, we have N < LD and N >= FD. FD is a Natural,
            --  So we can conclude, LD >= 1
            ND := LD - 1;
            pragma Assert (N + 1 <= Digs'Last);

            if Digs (N + 1) >= '5' then
               for J in reverse Digs'First + 1 .. Digs'First + N - 1 loop
                  pragma Assert (Digs (J) in '0' .. '9' | ' ' | '-');
                  --  Because it is a decimal image, we can assume that
                  --  it can only contain these characters.
                  D := Character'Succ (Digs (J));

                  if D <= '9' then
                     Digs (J) := D;
                     return;
                  else
                     Digs (J) := '0';
                  end if;
               end loop;

               --  Here the rounding overflows into the sign position. That's
               --  OK, because we already captured the value of the sign and
               --  we are in any case destroying the value in the Digs buffer

               Digs (Digs'First) := '1';
               FD := 1;
               ND := ND + 1;
               Digits_Before_Point := Digits_Before_Point + 1;
            end if;
         end if;
      end Round;

      ---------
      -- Set --
      ---------

      procedure Set (C : Character) is
      begin
         pragma Assert (P >= (S'First - 1) and P < S'Last and
                        P < Natural'Last);
         --  No check is done as documented in the header : updating P to
         --  point to the last character stored, the caller promises that the
         --  buffer is large enough and no check is made for this.
         --  Constraint_Error will not necessarily be raised if this
         --  requirement is violated, since it is perfectly valid to compile
         --  this unit with checks off.
         P := P + 1;
         S (P) := C;
      end Set;

      -------------------------
      -- Set_Blanks_And_Sign --
      -------------------------

      procedure Set_Blanks_And_Sign (N : Integer) is
      begin
         if Minus then
            for J in 1 .. N - 1 loop
               Set (' ');
            end loop;

            Set ('-');

         else
            for J in 1 .. N loop
               Set (' ');
            end loop;
         end if;
      end Set_Blanks_And_Sign;

      ----------------
      -- Set_Digits --
      ----------------

      procedure Set_Digits (S, E : Natural) is
      begin
         pragma Assert (S >= Digs'First and E <= Digs'Last);
         --  S and E should be in the Digs array range
         --  TBC: Analysis should be completed
         for J in S .. E loop
            Set (Digs (J));
         end loop;
      end Set_Digits;

      ----------------
      -- Set_Zeroes --
      ----------------

      procedure Set_Zeroes (N : Integer) is
      begin
         for J in 1 .. N loop
            Set ('0');
         end loop;
      end Set_Zeroes;

   --  Start of processing for Set_Decimal_Digits

   begin
      --  Case of exponent given

      if Exp > 0 then
         Set_Blanks_And_Sign (Fore - 1);
         Round (Digits_After_Point + 2);

         Set (Digs (FD));
         FD := FD + 1;
         pragma Assert (ND >= 1);
         ND := ND - 1;
         Set ('.');

         if ND >= Digits_After_Point then
            Set_Digits (FD, FD + Digits_After_Point - 1);
         else
            Set_Digits (FD, LD);
            Set_Zeroes (Digits_After_Point - ND);
         end if;

         --  Calculate exponent. The number of digits before the decimal point
         --  in the input is Digits_Before_Point, and the number of digits
         --  before the decimal point in the output is 1, so we can get the
         --  exponent as the difference between these two values. The one
         --  exception is for the value zero, which by convention has an
         --  exponent of +0.

         Expon := (if Zero then 0 else Digits_Before_Point - 1);

         Set ('E');
         ND := 0;

         if Expon >= 0 then
            Set ('+');
            Set_Image_Unsigned (Unsigned (Expon), Digs, ND);
         else
            Set ('-');
            Set_Image_Unsigned (Unsigned (-Expon), Digs, ND);
         end if;

         Set_Zeroes (Exp - ND - 1);
         Set_Digits (1, ND);
         return;

      --  Case of no exponent given. To make these cases clear, we use
      --  examples. For all the examples, we assume Fore = 2, Aft = 3.
      --  A P in the example input string is an implied zero position,
      --  not included in the input string.

      else
         --  Round at correct position
         --    Input: 4PP      => unchanged
         --    Input: 400.03   => unchanged
         --    Input  3.4567   => 3.457
         --    Input: 9.9999   => 10.000
         --    Input: 0.PPP5   => 0.001
         --    Input: 0.PPP4   => 0
         --    Input: 0.00003  => 0

         Round (LD - (Scale - Digits_After_Point));

         --  No digits before point in input
         --    Input: .123   Output: 0.123
         --    Input: .PP3   Output: 0.003

         if Digits_Before_Point <= 0 then
            Set_Blanks_And_Sign (Fore - 1);
            Set ('0');
            Set ('.');

            declare
               DA : Natural := Digits_After_Point;
               --  Digits remaining to output after point

               LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point);
               --  Number of leading zeroes after point. Note: there used to be
               --  a Max of this result with zero, but that's redundant, since
               --  we know DA is positive, and because of the test above, we
               --  know that -Digits_Before_Point >= 0.

            begin
               Set_Zeroes (LZ);
               DA := DA - LZ;

               if DA < ND then

                  --  Note: it is definitely possible for the above condition
                  --  to be True, for example:

                  --    V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0

                  --  but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0
                  --  so the arguments in the call are (1, 0) meaning that no
                  --  digits are output.

                  --  No obvious example exists where the following call to
                  --  Set_Digits actually outputs some digits, but we lack a
                  --  proof that no such example exists.

                  --  So it is safer to retain this call, even though as a
                  --  result it is hard (or perhaps impossible) to create a
                  --  coverage test for the inlined code of the call.

                  Set_Digits (FD, FD + DA - 1);

               else
                  Set_Digits (FD, LD);
                  Set_Zeroes (DA - ND);
               end if;
            end;

         --  At least one digit before point in input

         else
            --  Less digits in input than are needed before point
            --    Input: 1PP  Output: 100.000

            if ND < Digits_Before_Point then

               --  Special case, if the input is the single digit 0, then we
               --  do not want 000.000, but instead 0.000.

               if ND = 1 and then Digs (FD) = '0' then
                  Set_Blanks_And_Sign (Fore - 1);
                  Set ('0');

               --  Normal case where we need to output scaling zeroes

               else
                  Set_Blanks_And_Sign (Fore - Digits_Before_Point);
                  Set_Digits (FD, LD);
                  Set_Zeroes (Digits_Before_Point - ND);
               end if;

               --  Set period and zeroes after the period

               Set ('.');
               Set_Zeroes (Digits_After_Point);

            --  Input has full amount of digits before decimal point

            else
               Set_Blanks_And_Sign (Fore - Digits_Before_Point);
               pragma Assert (FD + Digits_Before_Point - 1 >= 0);
               --  In this branch, we have Digits_Before_Point > 0. It is the
               --  else of test (Digits_Before_Point <= 0)
               Set_Digits (FD, FD + Digits_Before_Point - 1);
               Set ('.');
               Set_Digits (FD + Digits_Before_Point, LD);
               Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point));
            end if;
         end if;
      end if;
   end Set_Decimal_Digits;

   --------------------------------
   -- Set_Floating_Invalid_Value --
   --------------------------------

   procedure Set_Floating_Invalid_Value
     (V    : Floating_Invalid_Value;
      S    : out String;
      P    : in out Natural;
      Fore : Natural;
      Aft  : Natural;
      Exp  : Natural)
   is
      procedure Set (C : Character);
      --  Sets character C in output buffer

      procedure Set_Special_Fill (N : Natural);
      --  After outputting +Inf, -Inf or NaN, this routine fills out the
      --  rest of the field with * characters. The argument is the number
      --  of characters output so far (either 3 or 4)

      ---------
      -- Set --
      ---------

      procedure Set (C : Character) is
      begin
         pragma Assert (P in S'First - 1 .. S'Last - 1);
         --  No check is done as documented in the header: updating P to point
         --  to the last character stored, the caller promises that the buffer
         --  is large enough and no check is made for this. Constraint_Error
         --  will not necessarily be raised if this requirement is violated,
         --  since it is perfectly valid to compile this unit with checks off.

         P := P + 1;
         S (P) := C;
      end Set;

      ----------------------
      -- Set_Special_Fill --
      ----------------------

      procedure Set_Special_Fill (N : Natural) is
      begin
         if Exp /= 0 then
            for J in N + 1 .. Fore + 1 + Aft + 1 + Exp loop
               Set ('*');
            end loop;

         else
            for J in N + 1 .. Fore + 1 + Aft loop
               Set ('*');
            end loop;
         end if;
      end Set_Special_Fill;

   --  Start of processing for Set_Floating_Invalid_Value

   begin
      case V is
         when Minus_Infinity =>
            Set ('-');
            Set ('I');
            Set ('n');
            Set ('f');
            Set_Special_Fill (4);

         when Infinity =>
            Set ('+');
            Set ('I');
            Set ('n');
            Set ('f');
            Set_Special_Fill (4);

         when Not_A_Number =>
            Set ('N');
            Set ('a');
            Set ('N');
            Set_Special_Fill (3);
      end case;
   end Set_Floating_Invalid_Value;

end System.Img_Util;