ada/xmlada
0
0
Fork 0
mirror of https://github.com/AdaCore/xmlada.git synced 2026-02-12 12:30:28 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
xmlada/schema/schema-decimal.adb
Fedor Rybin 6d195c06e0 Fix float value support in schema parsing 
for U112-003

Change-Id: I8cf1587ca13122a615768069d9ef51b8421658f3
2021-01-17 14:48:40 +03:00

791 lines
23 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- 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;
Reference in New Issue View Git Blame Copy Permalink