------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- ADA.NUMERICS.BIG_NUMBERS.BIG_REALS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2019-2020, 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 -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This is the default version of this package, based on Big_Integers only. with Ada.Strings.Text_Output.Utils; package body Ada.Numerics.Big_Numbers.Big_Reals is use Big_Integers; procedure Normalize (Arg : in out Big_Real); -- Normalize Arg by ensuring that Arg.Den is always positive and that -- Arg.Num and Arg.Den always have a GCD of 1. -------------- -- Is_Valid -- -------------- function Is_Valid (Arg : Big_Real) return Boolean is (Is_Valid (Arg.Num) and Is_Valid (Arg.Den)); --------- -- "/" -- --------- function "/" (Num, Den : Valid_Big_Integer) return Valid_Big_Real is Result : Big_Real; begin if Den = To_Big_Integer (0) then raise Constraint_Error with "divide by zero"; end if; Result.Num := Num; Result.Den := Den; Normalize (Result); return Result; end "/"; --------------- -- Numerator -- --------------- function Numerator (Arg : Valid_Big_Real) return Valid_Big_Integer is (Arg.Num); ----------------- -- Denominator -- ----------------- function Denominator (Arg : Valid_Big_Real) return Big_Positive is (Arg.Den); --------- -- "=" -- --------- function "=" (L, R : Valid_Big_Real) return Boolean is (abs L.Num = abs R.Num and then L.Den = R.Den); --------- -- "<" -- --------- function "<" (L, R : Valid_Big_Real) return Boolean is (abs L.Num * R.Den < abs R.Num * L.Den); ---------- -- "<=" -- ---------- function "<=" (L, R : Valid_Big_Real) return Boolean is (not (R < L)); --------- -- ">" -- --------- function ">" (L, R : Valid_Big_Real) return Boolean is (R < L); ---------- -- ">=" -- ---------- function ">=" (L, R : Valid_Big_Real) return Boolean is (not (L < R)); ----------------------- -- Float_Conversions -- ----------------------- package body Float_Conversions is ----------------- -- To_Big_Real -- ----------------- function To_Big_Real (Arg : Num) return Valid_Big_Real is begin return From_String (Arg'Image); end To_Big_Real; ------------------- -- From_Big_Real -- ------------------- function From_Big_Real (Arg : Big_Real) return Num is begin return Num'Value (To_String (Arg)); end From_Big_Real; end Float_Conversions; ----------------------- -- Fixed_Conversions -- ----------------------- package body Fixed_Conversions is ----------------- -- To_Big_Real -- ----------------- function To_Big_Real (Arg : Num) return Valid_Big_Real is begin return From_String (Arg'Image); end To_Big_Real; ------------------- -- From_Big_Real -- ------------------- function From_Big_Real (Arg : Big_Real) return Num is begin return Num'Value (To_String (Arg)); end From_Big_Real; end Fixed_Conversions; --------------- -- To_String -- --------------- function To_String (Arg : Valid_Big_Real; Fore : Field := 2; Aft : Field := 3; Exp : Field := 0) return String is Zero : constant Big_Integer := To_Big_Integer (0); Ten : constant Big_Integer := To_Big_Integer (10); function Leading_Padding (Str : String; Min_Length : Field; Char : Character := ' ') return String; -- Return padding of Char concatenated with Str so that the resulting -- string is at least Min_Length long. function Trailing_Padding (Str : String; Length : Field; Char : Character := '0') return String; -- Return Str with trailing Char removed, and if needed either -- truncated or concatenated with padding of Char so that the resulting -- string is Length long. function Image (N : Natural) return String; -- Return image of N, with no leading space. function Numerator_Image (Num : Big_Integer; After : Natural) return String; -- Return image of Num as a float value with After digits after the "." -- and taking Fore, Aft, Exp into account. ----------- -- Image -- ----------- function Image (N : Natural) return String is S : constant String := Natural'Image (N); begin return S (2 .. S'Last); end Image; --------------------- -- Leading_Padding -- --------------------- function Leading_Padding (Str : String; Min_Length : Field; Char : Character := ' ') return String is begin if Str = "" then return Leading_Padding ("0", Min_Length, Char); else return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0) => Char) & Str; end if; end Leading_Padding; ---------------------- -- Trailing_Padding -- ---------------------- function Trailing_Padding (Str : String; Length : Field; Char : Character := '0') return String is begin if Str'Length > 0 and then Str (Str'Last) = Char then for J in reverse Str'Range loop if Str (J) /= '0' then return Trailing_Padding (Str (Str'First .. J), Length, Char); end if; end loop; end if; if Str'Length >= Length then return Str (Str'First .. Str'First + Length - 1); else return Str & (1 .. Integer'Max (Integer (Length) - Str'Length, 0) => Char); end if; end Trailing_Padding; --------------------- -- Numerator_Image -- --------------------- function Numerator_Image (Num : Big_Integer; After : Natural) return String is Tmp : constant String := To_String (Num); Str : constant String (1 .. Tmp'Last - 1) := Tmp (2 .. Tmp'Last); Index : Integer; begin if After = 0 then return Leading_Padding (Str, Fore) & "." & Trailing_Padding ("0", Aft); else Index := Str'Last - After; if Index < 0 then return Leading_Padding ("0", Fore) & "." & Trailing_Padding ((1 .. -Index => '0') & Str, Aft) & (if Exp = 0 then "" else "E+" & Image (Natural (Exp))); else return Leading_Padding (Str (Str'First .. Index), Fore) & "." & Trailing_Padding (Str (Index + 1 .. Str'Last), Aft) & (if Exp = 0 then "" else "E+" & Image (Natural (Exp))); end if; end if; end Numerator_Image; begin if Arg.Num < Zero then declare Str : String := To_String (-Arg, Fore, Aft, Exp); begin if Str (1) = ' ' then for J in 1 .. Str'Last - 1 loop if Str (J + 1) /= ' ' then Str (J) := '-'; exit; end if; end loop; return Str; else return '-' & Str; end if; end; else -- Compute Num * 10^Aft so that we get Aft significant digits -- in the integer part (rounded) to display. return Numerator_Image ((Arg.Num * Ten ** Aft) / Arg.Den, After => Exp + Aft); end if; end To_String; ----------------- -- From_String -- ----------------- function From_String (Arg : String) return Big_Real is Ten : constant Big_Integer := To_Big_Integer (10); Frac : Big_Integer; Exp : Integer := 0; Pow : Natural := 0; Index : Natural := 0; Last : Natural := Arg'Last; begin for J in reverse Arg'Range loop if Arg (J) in 'e' | 'E' then if Last /= Arg'Last then raise Constraint_Error with "multiple exponents specified"; end if; Last := J - 1; Exp := Integer'Value (Arg (J + 1 .. Arg'Last)); Pow := 0; elsif Arg (J) = '.' then Index := J - 1; exit; else Pow := Pow + 1; end if; end loop; if Index = 0 then raise Constraint_Error with "invalid real value"; end if; declare Result : Big_Real; begin Result.Den := Ten ** Pow; Result.Num := From_String (Arg (Arg'First .. Index)) * Result.Den; Frac := From_String (Arg (Index + 2 .. Last)); if Result.Num < To_Big_Integer (0) then Result.Num := Result.Num - Frac; else Result.Num := Result.Num + Frac; end if; if Exp > 0 then Result.Num := Result.Num * Ten ** Exp; elsif Exp < 0 then Result.Den := Result.Den * Ten ** (-Exp); end if; Normalize (Result); return Result; end; end From_String; -------------------------- -- From_Quotient_String -- -------------------------- function From_Quotient_String (Arg : String) return Valid_Big_Real is Index : Natural := 0; begin for J in Arg'First + 1 .. Arg'Last - 1 loop if Arg (J) = '/' then Index := J; exit; end if; end loop; if Index = 0 then raise Constraint_Error with "no quotient found"; end if; return Big_Integers.From_String (Arg (Arg'First .. Index - 1)) / Big_Integers.From_String (Arg (Index + 1 .. Arg'Last)); end From_Quotient_String; --------------- -- Put_Image -- --------------- procedure Put_Image (S : in out Sink'Class; V : Big_Real) is -- This is implemented in terms of To_String. It might be more elegant -- and more efficient to do it the other way around, but this is the -- most expedient implementation for now. begin Strings.Text_Output.Utils.Put_UTF_8 (S, To_String (V)); end Put_Image; --------- -- "+" -- --------- function "+" (L : Valid_Big_Real) return Valid_Big_Real is Result : Big_Real; begin Result.Num := L.Num; Result.Den := L.Den; return Result; end "+"; --------- -- "-" -- --------- function "-" (L : Valid_Big_Real) return Valid_Big_Real is (Num => -L.Num, Den => L.Den); ----------- -- "abs" -- ----------- function "abs" (L : Valid_Big_Real) return Valid_Big_Real is (Num => abs L.Num, Den => L.Den); --------- -- "+" -- --------- function "+" (L, R : Valid_Big_Real) return Valid_Big_Real is Result : Big_Real; begin Result.Num := L.Num * R.Den + R.Num * L.Den; Result.Den := L.Den * R.Den; Normalize (Result); return Result; end "+"; --------- -- "-" -- --------- function "-" (L, R : Valid_Big_Real) return Valid_Big_Real is Result : Big_Real; begin Result.Num := L.Num * R.Den - R.Num * L.Den; Result.Den := L.Den * R.Den; Normalize (Result); return Result; end "-"; --------- -- "*" -- --------- function "*" (L, R : Valid_Big_Real) return Valid_Big_Real is Result : Big_Real; begin Result.Num := L.Num * R.Num; Result.Den := L.Den * R.Den; Normalize (Result); return Result; end "*"; --------- -- "/" -- --------- function "/" (L, R : Valid_Big_Real) return Valid_Big_Real is Result : Big_Real; begin Result.Num := L.Num * R.Den; Result.Den := L.Den * R.Num; Normalize (Result); return Result; end "/"; ---------- -- "**" -- ---------- function "**" (L : Valid_Big_Real; R : Integer) return Valid_Big_Real is Result : Big_Real; begin if R = 0 then Result.Num := To_Big_Integer (1); Result.Den := To_Big_Integer (1); else if R < 0 then Result.Num := L.Den ** (-R); Result.Den := L.Num ** (-R); else Result.Num := L.Num ** R; Result.Den := L.Den ** R; end if; Normalize (Result); end if; return Result; end "**"; --------- -- Min -- --------- function Min (L, R : Valid_Big_Real) return Valid_Big_Real is (if L < R then L else R); --------- -- Max -- --------- function Max (L, R : Valid_Big_Real) return Valid_Big_Real is (if L > R then L else R); --------------- -- Normalize -- --------------- procedure Normalize (Arg : in out Big_Real) is Zero : constant Big_Integer := To_Big_Integer (0); begin if Arg.Den < Zero then Arg.Num := -Arg.Num; Arg.Den := -Arg.Den; end if; if Arg.Num = Zero then Arg.Den := To_Big_Integer (1); else declare GCD : constant Big_Integer := Greatest_Common_Divisor (Arg.Num, Arg.Den); begin Arg.Num := Arg.Num / GCD; Arg.Den := Arg.Den / GCD; end; end if; end Normalize; end Ada.Numerics.Big_Numbers.Big_Reals;