xmlada_24.0.0_ae5a015b/schema/schema-decimal.adb

------------------------------------------------------------------------------
--                     XML/Ada - An XML suite for Ada95                     --
--                                                                          --
--                     Copyright (C) 2005-2021, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY 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/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

pragma Warnings (Off, "*is an internal GNAT unit");
with System.Img_Real;           use System.Img_Real;
pragma Warnings (On, "*is an internal GNAT unit");
with Ada.Strings.Fixed;         use Ada.Strings.Fixed;
with Ada.Strings.Maps;          use Ada.Strings.Maps;
with Sax.Encodings;             use Sax.Encodings;
with Sax.Symbols;               use Sax.Symbols;
with Sax.Utils;                 use Sax.Utils;
with Unicode.CES;               use Unicode, Unicode.CES;
with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin;

package body Schema.Decimal is

   type Compare_Result is (Less_Than, Equal, Greater_Than);
   function Compare (Num1, Num2 : String) return Compare_Result;
   --  Compare two numbers

   function Get_Exp (Num : String) return Long_Long_Integer;
   --  Return the exponential part of Num (ie the part after 'E').

   procedure Get_Fore (Num : String; First, Last : out Integer);
   --  Return the position of the first and last digit in the integer part of
   --  Num

   procedure Get_Aft
     (Num         : String;
      Fore_Last   : Integer;
      First, Last : out Integer);
   --  Return the last significant position in the number, ignoring trailing 0.
   --  Fore_Last is the value returned by Get_Fore

   procedure To_Next_Digit (Num : String; Pos : in out Integer);
   --  Move Pos to the next digit in Num

   procedure Internal_Value
     (Ch             : Unicode.CES.Byte_Sequence;
      Symbols        : Sax.Utils.Symbol_Table;
      Allow_Exponent : Boolean;
      Val            : out Arbitrary_Precision_Number;
      Error          : out Symbol);
   --  Internal implementation of Value

   -----------
   -- Image --
   -----------

   function Image
     (Number : Arbitrary_Precision_Number) return Unicode.CES.Byte_Sequence is
   begin
      if Number.Value /= No_Symbol then
         return Get (Number.Value).all;
      else
         return "0";
      end if;
   end Image;

   -----------
   -- Value --
   -----------

   function Value
     (Val : Sax.Symbols.Symbol) return Arbitrary_Precision_Number
   is
   begin
      return (Value => Val);
   end Value;

   -----------
   -- Value --
   -----------

   procedure Value
     (Symbols : Sax.Utils.Symbol_Table;
      Ch      : Unicode.CES.Byte_Sequence;
      Val     : out Arbitrary_Precision_Number;
      Error   : out Sax.Symbols.Symbol) is
   begin
      Internal_Value (Ch, Symbols, True, Val, Error);
   end Value;

   --------------------
   -- Internal_Value --
   --------------------

   procedure Internal_Value
     (Ch             : Unicode.CES.Byte_Sequence;
      Symbols        : Sax.Utils.Symbol_Table;
      Allow_Exponent : Boolean;
      Val            : out Arbitrary_Precision_Number;
      Error          : out Symbol)
   is
      Pos          : Integer := Ch'First;
      First, Last  : Integer;
      C            : Unicode_Char;
      Saw_Exponent : Boolean := False;
      Saw_Point    : Boolean := False;
   begin
      if Ch'Length = 0 then
         Error := Find (Symbols, "Invalid: empty string used as a number");
         Val := Undefined_Number;
         return;
      end if;

      --  Skip leading spaces (because the "whitespace" facet is always
      --  "collapse"

      while Pos <= Ch'Last loop
         First := Pos;
         Encoding.Read (Ch, Pos, C);
         exit when not Is_White_Space (C);
      end loop;

      --  Skip sign, if any

      if C = Plus_Sign or C = Hyphen_Minus then
         Encoding.Read (Ch, Pos, C);
      end if;

      Last := Pos - 1;

      --  Check we only have digits from now on

      loop
         if C = Full_Stop then
            if Saw_Point then
               Error := Find
                 (Symbols, "Only one decimal separator allowed in " & Ch);
               Val := Undefined_Number;
               return;
            end if;
            Saw_Point := True;

         elsif C = Latin_Capital_Letter_E
           or else C = Latin_Small_Letter_E
         then
            if Saw_Exponent then
               Error := Find (Symbols, "Only one exponent allowed in " & Ch);
               Val := Undefined_Number;
               return;
            end if;

            if not Allow_Exponent then
               Error := Find
                 (Symbols, "Exponent parent not authorized in " & Ch);
               Val := Undefined_Number;
               return;
            end if;

            Saw_Exponent := True;
            Saw_Point := False;

            if Pos > Ch'Last then
               Error  := Find (Symbols, "No exponent specified in " & Ch);
               Val := Undefined_Number;
               return;

            else
               declare
                  Save : constant Integer := Pos;
               begin
                  Encoding.Read (Ch, Pos, C);
                  if C /= Plus_Sign and C /= Hyphen_Minus then
                     Pos := Save;
                  end if;
               end;
            end if;

         elsif not Is_Digit (C) then
            --  Skip trailing spaces
            if Is_White_Space (C) then
               while Pos <= Ch'Last loop
                  Encoding.Read (Ch, Pos, C);
                  if not Is_White_Space (C) then
                     Error :=
                       Find (Symbols, "Invalid integer: """ & Ch & """");
                     Val := Undefined_Number;
                     return;
                  end if;
               end loop;
               exit;

            else
               Error := Find (Symbols, "Invalid integer: """ & Ch & """");
               Val := Undefined_Number;
               return;
            end if;
         end if;

         Last := Pos - 1;
         exit when Pos > Ch'Last;
         Encoding.Read (Ch, Pos, C);
      end loop;

      Error := No_Symbol;

      if Ch (First .. Last) = "-0" then
         Val := (Value => Find (Symbols, "0"));
      else
         Val := (Value => Find (Symbols, Ch (First .. Last)));
      end if;
   end Internal_Value;

   -----------------------
   -- Value_No_Exponent --
   -----------------------

   procedure Value_No_Exponent
     (Symbols : Sax.Utils.Symbol_Table;
      Ch      : Unicode.CES.Byte_Sequence;
      Val     : out Arbitrary_Precision_Number;
      Error   : out Sax.Symbols.Symbol) is
   begin
      Internal_Value (Ch, Symbols, False, Val, Error);
   end Value_No_Exponent;

   -------------
   -- Get_Aft --
   -------------

   procedure Get_Aft
     (Num       : String;
      Fore_Last : Integer;
      First     : out Integer;
      Last      : out Integer)
   is
      Exp_First : Integer := Num'Last + 1;
   begin
      --  Does the number end with an exponent or a fractional part ?

      Last := Num'Last;
      while Last > Fore_Last loop
         if Num (Last) = 'e'
           or else Num (Last) = 'E'
         then
            Exp_First := Last;
         end if;

         Last := Last - 1;
      end loop;

      First := Fore_Last + 1;

      if First <= Num'Last
        and then Num (First) = '.'
      then
         First := First + 1;
         if First < Exp_First then
            Last := Exp_First - 1;
            while Last >= First
              and then Num (Last) = '0'
            loop
               Last := Last - 1;
            end loop;
         end if;

      else
         Last := First - 1;  --  no fractional part
      end if;
   end Get_Aft;

   -------------
   -- Get_Exp --
   -------------

   function Get_Exp (Num : String) return Long_Long_Integer is
      Pos : Integer := Num'Last;
   begin
      while Pos >= Num'First
        and then Num (Pos) /= 'E'
        and then Num (Pos) /= 'e'
      loop
         Pos := Pos - 1;
      end loop;

      if Pos >= Num'First then
         return Long_Long_Integer'Value (Num (Pos + 1 .. Num'Last));
      else
         return 0;
      end if;
   end Get_Exp;

   --------------
   -- Get_Fore --
   --------------

   procedure Get_Fore (Num : String; First, Last : out Integer) is
      Pos : Integer;
   begin
      if Num (Num'First) = '-' or else Num (Num'First) = '+' then
         First := Num'First + 1;
      else
         First := Num'First;
      end if;

      Pos := First;
      while Pos <= Num'Last
        and then Num (Pos) /= '.'
        and then Num (Pos) /= 'E'
        and then Num (Pos) /= 'e'
      loop
         Pos := Pos + 1;
      end loop;

      Last := Pos - 1;

      --  Skip leading 0, but always keep at least one digit before '.'

      while First < Last
        and then Num (First) = '0'
      loop
         First := First + 1;
      end loop;
   end Get_Fore;

   -------------------
   -- To_Next_Digit --
   -------------------

   procedure To_Next_Digit (Num : String; Pos : in out Integer) is
   begin
      Pos := Pos + 1;

      if Pos <= Num'Last then
         if Num (Pos) = 'E' or Num (Pos) = 'e' then
            Pos := Num'Last + 1;
         elsif Num (Pos) = '.' then
            Pos := Pos + 1;
         end if;
      end if;
   end To_Next_Digit;

   -------------
   -- Compare --
   -------------

   function Compare (Num1, Num2 : String) return Compare_Result is
      Num1_Negative : constant Boolean := Num1 (Num1'First) = '-';
      Num2_Negative : constant Boolean := Num2 (Num2'First) = '-';

      Exp1, Exp2 : Long_Long_Integer;
      Pos1, Pos2 : Integer;
      Fore_First1, Fore_Last1 : Integer;
      Fore_First2, Fore_Last2 : Integer;
   begin
      --  We have to normalize the numbers (take care of exponents
      if Num1_Negative and not Num2_Negative then
         return Less_Than;

      elsif not Num1_Negative and Num2_Negative then
         return Greater_Than;

      else
         --  They have the same sign
         Exp1 := Get_Exp (Num1);
         Exp2 := Get_Exp (Num2);

         Get_Fore (Num1, Fore_First1, Fore_Last1);
         Get_Fore (Num2, Fore_First2, Fore_Last2);

         --  Different lengths ?
         if Long_Long_Integer (Fore_Last1 - Fore_First1) + Exp1 >
           Long_Long_Integer (Fore_Last2 - Fore_First2) + Exp2
         then
            if Num1_Negative then
               return Less_Than;
            else
               return Greater_Than;
            end if;

         elsif Long_Long_Integer (Fore_Last1 - Fore_First1) + Exp1 <
           Long_Long_Integer (Fore_Last2 - Fore_First2) + Exp2
         then
            if Num1_Negative then
               return Greater_Than;
            else
               return Less_Than;
            end if;
         end if;

         --  Same length of fore parts, we need to compare the digits
         Pos1 := Fore_First1;
         Pos2 := Fore_First2;

         loop
            if Num1 (Pos1) > Num2 (Pos2) then
               if Num1_Negative then
                  return Less_Than;
               else
                  return Greater_Than;
               end if;

            elsif Num1 (Pos1) < Num2 (Pos2) then
               if Num1_Negative then
                  return Greater_Than;
               else
                  return Less_Than;
               end if;
            end if;

            To_Next_Digit (Num1, Pos1);
            To_Next_Digit (Num2, Pos2);

            if Pos1 > Num1'Last
              and then Pos2 > Num2'Last
            then
               return Equal;

            elsif Pos1 > Num1'Last then
               --  If only "0" remain (and because we are in the decimal part),
               --  the two numbers are equal.

               while Num2 (Pos2) = '0' loop
                  To_Next_Digit (Num2, Pos2);
                  if Pos2 > Num2'Last then
                     return Equal;
                  end if;
               end loop;

               if Num1_Negative then
                  return Greater_Than;
               else
                  return Less_Than;
               end if;

            elsif Pos2 > Num2'Last then
               --  If only "0" remain (and because we are in the decimal part),
               --  the two numbers are equal.

               while Num1 (Pos1) = '0' loop
                  To_Next_Digit (Num1, Pos1);
                  if Pos1 > Num1'Last then
                     return Equal;
                  end if;
               end loop;

               if Num1_Negative then
                  return Less_Than;
               else
                  return Greater_Than;
               end if;
            end if;
         end loop;
      end if;
   end Compare;

   ---------
   -- "<" --
   ---------

   function "<" (Num1, Num2 : Arbitrary_Precision_Number) return Boolean is
   begin
      return Compare (Get (Num1.Value).all, Get (Num2.Value).all) = Less_Than;
   end "<";

   ----------
   -- "<=" --
   ----------

   function "<=" (Num1, Num2 : Arbitrary_Precision_Number) return Boolean is
   begin
      return Compare (Get (Num1.Value).all, Get (Num2.Value).all) /=
        Greater_Than;
   end "<=";

   ---------
   -- "=" --
   ---------

   function "=" (Num1, Num2 : Arbitrary_Precision_Number) return Boolean is
   begin
      if Num1.Value = No_Symbol then
         return Num2.Value = No_Symbol;
      elsif Num2.Value = No_Symbol then
         return False;
      else
         return Compare (Get (Num1.Value).all, Get (Num2.Value).all) = Equal;
      end if;
   end "=";

   ----------
   -- ">=" --
   ----------

   function ">=" (Num1, Num2 : Arbitrary_Precision_Number) return Boolean is
   begin
      return Compare (Get (Num1.Value).all, Get (Num2.Value).all) /= Less_Than;
   end ">=";

   ---------
   -- ">" --
   ---------

   function ">" (Num1, Num2 : Arbitrary_Precision_Number) return Boolean is
   begin
      return Compare (Get (Num1.Value).all, Get (Num2.Value).all) =
        Greater_Than;
   end ">";

   ------------------
   -- Check_Digits --
   ------------------

   function Check_Digits
     (Symbols                       : Sax.Utils.Symbol_Table;
      Num                           : Arbitrary_Precision_Number;
      Fraction_Digits, Total_Digits : Integer := -1)
      return Sax.Symbols.Symbol
   is
      Value : constant Cst_Byte_Sequence_Access := Get (Num.Value);
      Exp   : constant Long_Long_Integer := Get_Exp (Value.all);

      Fore_First, Fore_Last : Integer;
      Pos                   : Integer;
      Digits_Count          : Natural := 0;
      Aft_First, Aft_Last   : Integer;
   begin
      Get_Fore (Value.all, Fore_First, Fore_Last);
      Get_Aft (Value.all, Fore_Last, Aft_First, Aft_Last);

      --  Now count the significant digits (including fractional part)
      Pos := Value'First;
      if Value (Pos) = '-' or Value (Pos) = '+' then
         Pos := Pos + 1;
      end if;

      if Value (Pos) = '.' then
         Pos := Pos + 1;
      end if;

      Digits_Count := Fore_Last - Fore_First + 1
        + Aft_Last - Aft_First + 1;

      if Total_Digits > 0 then
         if Digits_Count > Total_Digits then
            return Find
              (Symbols, "Number " & Value.all
               & " has too many digits (totalDigits is"
               & Integer'Image (Total_Digits) & ")");
         end if;
      end if;

      if Fraction_Digits >= 0 then
         if Long_Long_Integer (Aft_Last - Aft_First + 1) - Exp >
           Long_Long_Integer (Fraction_Digits)
         then
            return Find
              (Symbols, "Number " & Value.all
               & " has too many fractional digits (fractionDigits is"
               & Integer'Image (Fraction_Digits) & ')');
         end if;
      end if;

      return No_Symbol;
   end Check_Digits;

   ----------
   -- "<=" --
   ----------

   function "<=" (F1, F2 : XML_Float) return Boolean is
   begin
      case F1.Kind is
         when NaN =>
            return False;

         when Plus_Infinity =>
            return False;

         when Minus_Infinity =>
            return True;

         when Standard_Float =>
            case F2.Kind is
               when NaN =>
                  return False;

               when Plus_Infinity =>
                  return True;

               when Minus_Infinity =>
                  return False;

               when Standard_Float =>
                  if F2.Mantiss = 0.0 then
                     return F1.Mantiss <= 0.0;
                  elsif F2.Mantiss > 0.0 then
                     return (F1.Mantiss / F2.Mantiss) <=
                        10.0 ** (F2.Exp - F1.Exp);
                  else
                     return (F1.Mantiss / F2.Mantiss) >=
                        10.0 ** (F2.Exp - F1.Exp);
                  end if;
            end case;
      end case;
   end "<=";

   ----------
   -- ">=" --
   ----------

   function ">=" (F1, F2 : XML_Float) return Boolean is
   begin
      return not (F1 < F2);
   end ">=";

   ---------
   -- ">" --
   ---------

   function ">" (F1, F2 : XML_Float) return Boolean is
   begin
      return not (F1 <= F2);
   end ">";

   ---------
   -- "<" --
   ---------

   function "<" (F1, F2 : XML_Float) return Boolean is
   begin
      case F1.Kind is
         when NaN =>
            return False;

         when Plus_Infinity =>
            return False;

         when Minus_Infinity =>
            return True;

         when Standard_Float =>
            case F2.Kind is
               when NaN =>
                  return False;

               when Plus_Infinity =>
                  return True;

               when Minus_Infinity =>
                  return False;

               when Standard_Float =>
                  --  This is slow, but the division helps handle larger
                  --  numbers.
                  if F2.Mantiss = 0.0 then
                     return F1.Mantiss < 0.0;
                  elsif F2.Mantiss > 0.0 then
                     return (F1.Mantiss / F2.Mantiss) <
                        10.0 ** (F2.Exp - F1.Exp);
                  else
                     return (F1.Mantiss / F2.Mantiss) >
                        10.0 ** (F2.Exp - F1.Exp);
                  end if;
            end case;
      end case;
   end "<";

   -----------
   -- Value --
   -----------

   function Value (Str : String) return XML_Float is
      E : Integer;
      Exp : Integer;
      Mantiss : Long_Long_Float;
   begin
      if Str = "NaN" then
         return XML_Float'(Kind => NaN);
      elsif Str = "INF" then
         return XML_Float'(Kind => Plus_Infinity);
      elsif Str = "-INF" then
         return XML_Float'(Kind => Minus_Infinity);
      else
         --  The issue here is that XML can represent float numbers outside
         --  the range of Long_Long_Float. So we do a normalization in base
         --  10 of the form (Mantissa * 10**Exp) with 1.0 <= Mantissa < 10.0
         --  although this introduces rounding errors since the radix is 2.
         --  That's why we use the same precision as 'Image to swallow them.

         E := Index (Str, To_Set ("eE"));
         if E < Str'First then
            Exp := 0;
            Mantiss := Long_Long_Float'Value (Str);
         else
            Exp := Integer'Value (Str (E + 1 .. Str'Last));
            Mantiss := Long_Long_Float'Value (Str (Str'First .. E - 1));
         end if;

         --  IEEE Binary128 has 33 digits of mantissa and 5 digits of exponent
         --  so 64 characters are sufficient for the foreseable future.

         declare
            Exp_Chars : constant Natural := 5;
            Str2      : String (1 .. 64);
            P         : Integer := Str2'First - 1;
         begin
            System.Img_Real.Set_Image_Real
               (Mantiss,
                S => Str2,
                P => P,
                Fore => 1,
                Aft => Long_Long_Float'Digits - 1,
                Exp => Exp_Chars);
            Exp := Exp + Integer'Value (Str2 (P - Exp_Chars + 1 .. P));
            Mantiss := Long_Long_Float'Value
               (Str2 (Str2'First .. P - Exp_Chars - 1));
         end;

         return XML_Float'(Kind  => Standard_Float,
                           Mantiss => Mantiss,
                           Exp     => Exp);
      end if;
   end Value;

   -----------
   -- Image --
   -----------

   function Image (Value : XML_Float) return String is
   begin
      case Value.Kind is
         when NaN =>
            return "NaN";

         when Plus_Infinity =>
            return "INF";

         when Minus_Infinity =>
            return "-INF";

         when Standard_Float =>
            declare
               Str : constant String := Long_Long_Float'Image (Value.Mantiss);
               --  Always has a "E+00", by construction

               Exp : constant String := Integer'Image (Value.Exp);
               E   : Integer := Index (Str, "E");
               F   : Integer := Str'First;
            begin
               if E < Str'First then
                  E := Str'Last + 1;
               end if;

               if Str (F) = ' ' then
                  F := F + 1;
               end if;

               for J in reverse F .. E - 1 loop
                  if Str (J) /= '0' then
                     E := J + 1;
                     exit;
                  end if;
               end loop;

               if Value.Exp = 0 then
                  return Str (F .. E - 1);
               elsif Value.Exp > 0 then
                  return Str (F .. E - 1)
                     & "E+" & Exp (Exp'First + 1 .. Exp'Last);
               else
                  return Str (F .. E - 1) & "E" & Exp;
               end if;
            end;
      end case;
   end Image;

end Schema.Decimal;