------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2005-2012, 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. -- -- -- -- -- -- -- -- -- -- -- -- 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 -- -- . -- -- -- ------------------------------------------------------------------------------ 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 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 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 = Period 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_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; 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; Frac_Digits : Natural := 0; begin Get_Fore (Value.all, Fore_First, Fore_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; while Pos <= Value'last loop Digits_Count := Digits_Count + 1; if Pos > Fore_Last then Frac_Digits := Frac_Digits + 1; end if; To_Next_Digit (Value.all, Pos); end loop; if Total_Digits > 0 then -- Gross estimation if Long_Long_Integer (Fore_Last - Fore_First) + Exp >= Long_Long_Integer (Total_Digits) then return Find (Symbols, "Number " & Value.all & " has too many digits (totalDigits is" & Integer'image (Total_Digits) & ')'); end if; 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 (Frac_Digits) - 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 F1.Mantiss < 0.0 then if F2.Mantiss >= 0.0 then return True; else -- Same sign return F1.Exp > F2.Exp or else (F1.Exp = F2.Exp and F1.Mantiss <= F2.Mantiss); end if; else if F2.Mantiss < 0.0 then return False; else return F1.Exp < F2.Exp or else (F1.Exp = F2.Exp and F1.Mantiss <= F2.Mantiss); end if; 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 => if F1.Mantiss < 0.0 then if F2.Mantiss >= 0.0 then return True; else -- Same sign return F1.Exp > F2.Exp or else (F1.Exp = F2.Exp and F1.Mantiss < F2.Mantiss); end if; else if F2.Mantiss < 0.0 then return False; else return F1.Exp < F2.Exp or else (F1.Exp = F2.Exp and F1.Mantiss < F2.Mantiss); end if; 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 try a basic normalization of -- floats (mantissa * 10^exp) with 1.0<=mantissa<10.0 E := Index (Str, "E"); 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; declare Str2 : String (1 .. 200); P : Integer := Str2'first - 1; Exp_Chars : constant Natural := 5; begin System.Img_Real.Set_Image_Real (Mantiss, S => Str2, P => P, Fore => 1, Aft => 30, 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;