Skip to content

Instantly share code, notes, and snippets.

@ytomino
Created March 6, 2011 07:13
Show Gist options
  • Save ytomino/857100 to your computer and use it in GitHub Desktop.
Save ytomino/857100 to your computer and use it in GitHub Desktop.
Universal Representation of Real numbers
with Ada.Unchecked_Conversion;
with Ada.Numerics.Long_Long_Elementary_Functions;
with Interfaces;
package body URR is
function Shift_Left (Value : URR_Representation; Amount : Natural) return URR_Representation;
pragma Import (Intrinsic, Shift_Left);
function To_URR_Real (X : URR_Representation) return URR_Real is
begin
return URR_Real (X);
end To_URR_Real;
function To_URR_Representation (X : URR_Real) return URR_Representation is
begin
return URR_Representation (X);
end To_URR_Representation;
function "<" (Left, Right : URR_Real) return Boolean is
begin
if URR_Representation'Size <= 32 then
declare
use type Interfaces.Integer_32;
function C is new Ada.Unchecked_Conversion (Interfaces.Unsigned_32, Interfaces.Integer_32);
L : constant Interfaces.Unsigned_32 := Interfaces.Unsigned_32 (Left);
R : constant Interfaces.Unsigned_32 := Interfaces.Unsigned_32 (Right);
begin
return C (L) < C (R);
end;
else
declare
use type Interfaces.Integer_64;
function C is new Ada.Unchecked_Conversion (Interfaces.Unsigned_64, Interfaces.Integer_64);
L : constant Interfaces.Unsigned_64 := Interfaces.Unsigned_64 (Left);
R : constant Interfaces.Unsigned_64 := Interfaces.Unsigned_64 (Right);
begin
return C (L) < C (R);
end;
end if;
end "<";
function "<=" (Left, Right : URR_Real) return Boolean is
begin
return not (Right < Left);
end "<=";
function ">" (Left, Right : URR_Real) return Boolean is
begin
return Right < Left;
end ">";
function ">=" (Left, Right : URR_Real) return Boolean is
begin
return not (Left < Right);
end ">=";
function "+" (X : URR_Real) return URR_Real is
begin
return X;
end "+";
function "-" (X : URR_Real) return URR_Real is
begin
return URR_Real (1 + not URR_Representation (X));
end "-";
function "abs" (X : URR_Real) return URR_Real is
use Interfaces;
H : constant URR_Representation := Shift_Left (1, URR_Representation'Size - 1);
begin
if (URR_Representation (X) and H) /= 0 then
return - X;
else
return X;
end if;
end "abs";
function To_URR_Real (X : Long_Long_Float) return URR_Real is
use Ada.Numerics.Long_Long_Elementary_Functions;
use Interfaces;
begin
if X = 0.0 then
return 0;
elsif X <= Long_Long_Float'First then
return URR_Real (URR_Representation'(Shift_Left (1, URR_Representation'Size - 1)));
else
declare
A : constant Long_Long_Float := abs X;
B : URR_Representation := Shift_Left (1, URR_Representation'Size - 2);
R, U, L : Long_Long_Float;
Result : URR_Representation;
begin
Result := 0;
Search: loop
L := 0.0;
U := 1.0;
if A >= 1.0 then
L := 1.0;
U := 2.0;
Result := Result or B;
B := B / 2;
if A >= 2.0 then
Result := Result or B;
B := B / 2;
L := 2.0;
loop
U := L * L;
exit when U > A;
L := U;
Result := Result or B;
B := B / 2;
end loop;
while U - L > 2.0 loop
B := B / 2;
exit Search when B = 0;
R := Sqrt (U * L);
if A >= R then
Result := Result or B;
L := R;
else
U := R;
end if;
end loop;
end if;
end if;
B := B / 2;
exit Search when B = 0;
while B /= 0 loop
R := (U + L) / 2.0;
if A >= R then
Result := Result or B;
L := R;
else
U := R;
end if;
B := B / 2;
end loop;
exit;
end loop Search;
if A /= X then
return - URR_Real (Result);
else
return URR_Real (Result);
end if;
end;
end if;
end To_URR_Real;
function To_Long_Long_Float (X : URR_Real) return Long_Long_Float is
use Ada.Numerics.Long_Long_Elementary_Functions;
use Interfaces;
begin
if URR_Representation (X) = 0 then
return 0.0;
elsif URR_Representation (X) = Shift_Left (1, URR_Representation'Size - 1) then
return Long_Long_Float'First;
else
declare
A : constant URR_Representation := URR_Representation (abs X);
B : URR_Representation := Shift_Left (1, URR_Representation'Size - 2);
R, U, L : Long_Long_Float;
Result : Long_Long_Float;
begin
Result := 0.0;
Search : loop
L := 0.0;
U := 1.0;
if (A and B) /= 0 then
Result := 1.0;
L := 1.0;
U := 2.0;
B := B / 2;
if (A and B) /= 0 then
Result := 2.0;
B := B / 2;
while (A and B) /= 0 loop
Result := Result * Result;
B := B / 2;
exit Search when B = 0;
end loop;
L := Result;
U := Result * Result;
while U - L > 2.0 loop
B := B / 2;
exit Search when B = 0;
R := Sqrt (U * L);
if (A and B) /= 0 then
Result := R;
L := R;
else
U := R;
end if;
end loop;
end if;
end if;
B := B / 2;
exit Search when B = 0;
while B /= 0 loop
R := (U + L) / 2.0;
if (A and B) /= 0 then
Result := R;
L := R;
else
U := R;
end if;
B := B / 2;
end loop;
exit;
end loop Search;
if URR_Representation (X) /= A then
return - Result;
else
return Result;
end if;
end;
end if;
end To_Long_Long_Float;
end URR;
generic
type URR_Representation is mod <>;
package URR is
pragma Pure;
pragma Assert ((URR_Representation'Last and (URR_Representation'Last + 1)) = 0);
type URR_Real is private;
function To_URR_Real (X : URR_Representation) return URR_Real;
pragma Inline (To_URR_Real);
function To_URR_Representation (X : URR_Real) return URR_Representation;
pragma Inline (To_URR_Representation);
-- function "=" (Left, Right : URR_Real) return Boolean;
-- "=", "/=" are OK by default.
function "<" (Left, Right : URR_Real) return Boolean;
function "<=" (Left, Right : URR_Real) return Boolean;
pragma Inline ("<=");
function ">" (Left, Right : URR_Real) return Boolean;
pragma Inline (">");
function ">=" (Left, Right : URR_Real) return Boolean;
pragma Inline (">=");
function "+" (X : URR_Real) return URR_Real;
function "-" (X : URR_Real) return URR_Real;
function "abs" (X : URR_Real) return URR_Real;
function To_URR_Real (X : Long_Long_Float) return URR_Real;
function To_Long_Long_Float (X : URR_Real) return Long_Long_Float;
private
type URR_Real is new URR_Representation;
end URR;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment