Universal Representation of Real numbers

urr.adb

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;

urr.ads

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;