|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 20480 (0x5000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Generic_Primitive_Functions, seg_0069d1
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
-- This package body contains an implementation of the proposed standard for
-- primitive real arithmetic functions, as defined by the
-- ISO-IEC/JTC1/SC22/WG9 (Ada) committee (draft 1.0, December 1990)
--
-- Users recognize that the Math Support packages provided as part of the
-- Rational Environment are delivered "AS IS". No warranties are given,
-- whether express, implied, or statutory, including implied warranties of
-- fitness for a particular purpose or mechantability. In no event will
-- Rational be liable in tort, negligence, or other liability incurred as a
-- result of the use of this Math Support packages.
--
-- In addition, Rational does not guarantee conformance to the proposed
-- standards, especially in the accuracy of the results of the various math
-- functions.
--
-- This code can be distributed and modified freely, although Rational
-- would be happy to receive comments, bug reports, and suggestions for
-- improvements at:
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, CA 95054 USA
-- or by e-mail at:
-- Support@Rational.COM
--
with Unchecked_Conversion;
package body Generic_Primitive_Functions is
-- This is a non-portable implementation for the R1000 architecture.
--
-- The R1000 supports only one floating-point type: FLOAT.
-- Values of the type FLOAT are represented using the double (ie. 64 bits)
-- float format specified by the IEEE Standard for Binary Floating Point
-- Arithmetic (ANSI/IEEE Std.754-1985).
-- The R1000 compiler does not support "not a number" values and the value
-- for negative zero.
type Sign is new Boolean;
for Sign'Size use 1;
type Biased_Exponent is range 0 .. 2 ** 11 - 1;
for Biased_Exponent'Size use 11;
Exponent_Bias : constant := -1022;
Not_A_Number_Exp : constant := 1025;
Gradual_Underflow_Exp : constant := Exponent_Bias;
type Mantissa is range 0 .. 2 ** 52 - 1;
for Mantissa'Size use 52;
type Float_Representation is
record
Sign_Bit : Sign;
Exponent_Part : Biased_Exponent;
Mantissa_Part : Mantissa;
end record;
-- for Float_Representation use
-- record
-- Sign_Bit at 0 range 0 .. 0;
-- Exponent_Part at 0 range 1 .. 11;
-- Mantissa_Part at 0 range 12 .. 63;
-- end record;
function Conv is new Unchecked_Conversion (Float_Type, Float_Representation);
function Conv is new Unchecked_Conversion (Float_Representation, Float_Type);
Largest_Representable_Positive : constant := 2#1.0#E+53;
Smallest_Positive : Float_Type :=
Conv (Float_Representation'
(Sign_Bit => False, Exponent_Part => 0, Mantissa_Part => 1));
Smallest_Negative : Float_Type :=
Conv (Float_Representation'
(Sign_Bit => True, Exponent_Part => 0, Mantissa_Part => 1));
type Complete_Mantissa is range 0 .. 2 ** 53 - 1;
Mantissa_Complement : constant := 2 ** 52;
type Mantissa_Bit_String is array (1 .. 52) of Boolean;
pragma Pack (Mantissa_Bit_String);
function Conv is new Unchecked_Conversion (Mantissa_Bit_String, Mantissa);
function Conv is new Unchecked_Conversion (Mantissa, Mantissa_Bit_String);
-------------------------------------------------------------------------------
function Exponent (X : Float_Type) return Exponent_Type is
F : Float_Type;
E : Exponent_Type;
begin
Decompose (X, Fraction => F, Exponent => E);
return E;
end Exponent;
function Fraction (X : Float_Type) return Float_Type is
F : Float_Type;
E : Exponent_Type;
begin
Decompose (X, Fraction => F, Exponent => E);
return F;
end Fraction;
procedure Decompose (X : in Float_Type;
Fraction : out Float_Type;
Exponent : out Exponent_Type) is
X_Repr : Float_Representation := Conv (X);
Exp : Exponent_Type := Exponent_Type
(X_Repr.Exponent_Part + Exponent_Bias);
M : Complete_Mantissa;
begin
if X = 0.0 then
Fraction := 0.0;
Exponent := 0;
elsif Exp = Gradual_Underflow_Exp then
-- renormalized number
M := Complete_Mantissa (X_Repr.Mantissa_Part);
while M < Mantissa_Complement loop
M := M * 2;
Exp := Exp - 1;
end loop;
X_Repr.Mantissa_Part := Mantissa (M - Mantissa_Complement);
X_Repr.Exponent_Part := Biased_Exponent (0 - Exponent_Bias);
Fraction := Conv (X_Repr);
Exponent := Exp;
elsif Exp >= Not_A_Number_Exp then
raise Constraint_Error;
else -- normal case
X_Repr.Exponent_Part := Biased_Exponent (0 - Exponent_Bias);
Fraction := Conv (X_Repr);
Exponent := Exp;
end if;
end Decompose;
function Compose (Fraction : Float_Type;
Exponent : Exponent_Type) return Float_Type is
X_Repr : Float_Representation := Conv (Fraction);
begin
if Fraction = 0.0 then
return 0.0;
elsif Exponent >= Not_A_Number_Exp then
raise Constraint_Error;
elsif Exponent <= Gradual_Underflow_Exp then
return Copy_Sign (Float_Type'Small, Fraction); -- can be improved
else
X_Repr.Exponent_Part := Biased_Exponent (Exponent - Exponent_Bias);
return Conv (X_Repr);
end if;
end Compose;
function Scale (X : Float_Type;
Exponent : Exponent_Type) return Float_Type is
X_Repr : Float_Representation := Conv (X);
Temp_Exp : Exponent_Type;
begin
if X = 0.0 then
return 0.0;
end if;
Temp_Exp := Exponent_Type (X_Repr.Exponent_Part) + Exponent;
if Temp_Exp >= Not_A_Number_Exp then
raise Constraint_Error;
elsif Temp_Exp <= Gradual_Underflow_Exp then
return Copy_Sign (Float_Type'Small, X); -- can be improved
else
X_Repr.Exponent_Part := Biased_Exponent (Temp_Exp - Exponent_Bias);
return Conv (X_Repr);
end if;
end Scale;
function Floor (X : Float_Type) return Float_Type is
Trunc : Float_Type;
begin
if abs X > Largest_Representable_Positive then
return X;
end if;
Trunc := Truncate (X);
if X >= 0.0 or else Trunc = X then
return Trunc;
else
return Trunc - 1.0;
end if;
end Floor;
function Ceiling (X : Float_Type) return Float_Type is
Trunc : Float_Type;
begin
if abs X > Largest_Representable_Positive then
return X;
end if;
Trunc := Truncate (X);
if X <= 0.0 or else Trunc = X then
return Trunc;
else
return Trunc + 1.0;
end if;
end Ceiling;
function Is_Odd (F : Float_Type) return Boolean is
F_Over_2 : Float_Type := F / 2.0;
begin
return (Truncate (F_Over_2) /= F_Over_2);
end Is_Odd;
function Round (X : Float_Type) return Float_Type is
Abs_X : Float_Type := abs X;
Trunc, Frac : Float_Type;
begin
if Abs_X > Largest_Representable_Positive then
return X;
end if;
Trunc := Truncate (Abs_X);
Frac := Abs_X - Trunc;
if Frac > 0.5 then
return Copy_Sign (Trunc + 1.0, X);
elsif Frac < 0.5 then
return Copy_Sign (Trunc, X);
-- Frac = 0.5
-- we have a tie: need to go to the even integer
elsif Is_Odd (Trunc) then
return Copy_Sign (Trunc + 1.0, X);
else
return Copy_Sign (Trunc, X);
end if;
end Round;
function Truncate (X : Float_Type) return Float_Type is
begin
if abs X > Largest_Representable_Positive then
return X;
elsif abs X < 1.0 then
return 0.0;
else
return Leading_Part (X, Integer (Exponent (X)));
end if;
end Truncate;
function Remainder (X, Y : Float_Type) return Float_Type is
begin
if Y = 0.0 then
raise Constraint_Error;
end if;
return X - (Y * Round (X / Y));
end Remainder;
function Adjacent (X, Towards : Float_Type) return Float_Type is
begin
if X = Towards then
return X;
elsif X < Towards then
return Successor (X);
else
return Predecessor (X);
end if;
end Adjacent;
function Successor (X : Float_Type) return Float_Type is
F : Float_Type;
E : Exponent_Type;
X_Repr : Float_Representation := Conv (X);
M : Complete_Mantissa;
begin
if X >= Float_Type'Base'Last then
raise Constraint_Error;
end if;
if X = 0.0 then
return Smallest_Positive;
end if;
M := Complete_Mantissa (X_Repr.Mantissa_Part) + 1;
if M > Complete_Mantissa (Mantissa'Last) then
X_Repr.Mantissa_Part := 0;
X_Repr.Exponent_Part := X_Repr.Exponent_Part + 1;
else
X_Repr.Mantissa_Part := Mantissa (M);
end if;
return Conv (X_Repr);
end Successor;
function Predecessor (X : Float_Type) return Float_Type is
X_Repr : Float_Representation := Conv (X);
M : Mantissa;
begin
if X <= -Float_Type'Base'Last then
raise Constraint_Error;
end if;
if X = 0.0 then
return Smallest_Negative;
end if;
M := X_Repr.Mantissa_Part;
if M = 0 then
X_Repr.Mantissa_Part := Mantissa'Last;
X_Repr.Exponent_Part := X_Repr.Exponent_Part - 1;
else
X_Repr.Mantissa_Part := M - 1;
end if;
return Conv (X_Repr);
end Predecessor;
function Copy_Sign (Value, Sign : Float_Type) return Float_Type is
begin
if Sign >= 0.0 then
return abs Value;
else
return -(abs Value);
end if;
end Copy_Sign;
function Leading_Part (X : Float_Type;
Radix_Digits : Positive) return Float_Type is
F : Float_Type;
E : Exponent_Type;
F_Repr : Float_Representation;
M_Bits : Mantissa_Bit_String;
begin
Decompose (X, F, E);
F_Repr := Conv (F);
M_Bits := Conv (F_Repr.Mantissa_Part);
for Bit in Radix_Digits .. Mantissa_Bit_String'Last loop
M_Bits (Bit) := False;
end loop;
F_Repr.Mantissa_Part := Mantissa (Conv (M_Bits));
F := Conv (F_Repr);
return Compose (F, E);
end Leading_Part;
end Generic_Primitive_Functions;
nblk1=13
nid=12
hdr6=24
[0x00] rec0=14 rec1=00 rec2=01 rec3=028
[0x01] rec0=1b rec1=00 rec2=02 rec3=000
[0x02] rec0=1b rec1=00 rec2=13 rec3=042
[0x03] rec0=02 rec1=00 rec2=03 rec3=000
[0x04] rec0=20 rec1=00 rec2=04 rec3=018
[0x05] rec0=1b rec1=00 rec2=05 rec3=06c
[0x06] rec0=01 rec1=00 rec2=11 rec3=03e
[0x07] rec0=24 rec1=00 rec2=06 rec3=00e
[0x08] rec0=00 rec1=00 rec2=10 rec3=01c
[0x09] rec0=25 rec1=00 rec2=07 rec3=038
[0x0a] rec0=24 rec1=00 rec2=08 rec3=002
[0x0b] rec0=00 rec1=00 rec2=0f rec3=00e
[0x0c] rec0=28 rec1=00 rec2=09 rec3=01a
[0x0d] rec0=00 rec1=00 rec2=0e rec3=01e
[0x0e] rec0=20 rec1=00 rec2=0a rec3=062
[0x0f] rec0=00 rec1=00 rec2=0d rec3=00a
[0x10] rec0=24 rec1=00 rec2=0b rec3=014
[0x11] rec0=01 rec1=00 rec2=0c rec3=000
[0x12] rec0=00 rec1=00 rec2=01 rec3=100
tail 0x215016eae81c04dea710c 0x42a00066462061e03
Free Block Chain:
0x12: 0000 00 00 00 1e 80 15 4d 61 6e 74 69 73 73 61 5f 50 ┆ Mantissa_P┆