⟦73d8b862d⟧

TextFile

with Float_Operations;
with Unchecked_Conversion;
package body Long_Primitive_Functions is

    package Mc68881 renames Float_Operations.Double;

    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;

    type Mantissa_H is array (1 .. 20) of Boolean;
    pragma Pack (Mantissa_H);

    type Mantissa_L is array (21 .. 52) of Boolean;
    pragma Pack (Mantissa_L);

    type Float_Representation is
        record
            Sign_Bit : Sign;
            Exponent_Part : Biased_Exponent;
            Mantissa_Part_H : Mantissa_H;
            Mantissa_Part_L : Mantissa_L;
        end record;

    for Float_Representation use
        record
            Sign_Bit at 0 range 0 .. 0;
            Exponent_Part at 0 range 1 .. 11;
            Mantissa_Part_H at 0 range 12 .. 31;
            Mantissa_Part_L at 0 range 32 .. 63;
        end record;

    function Conv is new Unchecked_Conversion
                            (Long_Float, Float_Representation);
    function Conv is new Unchecked_Conversion
                            (Float_Representation, Long_Float);

    Largest_Representable_Positive : constant := 2#1.0#E+53;

    -- The notion of Fraction and Exponent of the designers of the Mc68881
    -- does not match exactly the definition given in the Ada standard:
    --   - the 68881 return a fraction in the range [1.0 .. 2.0)
    --   - the standard calls for the range         [0.5 .. 1.0)
    -- hence those 2 additional utilities
    --
    function Exp (X : Long_Float) return Integer is
    begin
        return Integer (Mc68881.Exponent (X)) + 1;
    end Exp;
    function Frac (X : Long_Float) return Long_Float is
    begin
        return Mc68881.Scale (Mc68881.Mantissa (X), -1);
    end Frac;
    pragma Inline (Exp, Frac);

    function Is_Odd (F : Long_Float) return Boolean is
        -- assume F is integer
        F_Over_2 : Long_Float := F / 2.0;
    begin
        return Truncate (F_Over_2) /= F_Over_2;
    end Is_Odd;

-------------------------------------------------------------------------------

    function Exponent (X : Long_Float) return Integer is
    begin
        return Exp (X);
    end Exponent;


    function Fraction (X : Long_Float) return Long_Float is
    begin
        return Frac (X);
    end Fraction;


    procedure Decompose (X : in Long_Float;
                         Fraction : out Long_Float;
                         Exponent : out Integer) is
    begin
        Fraction := Frac (X);
        Exponent := Exp (X);
    end Decompose;


    function Compose (Fraction : Long_Float;  
                      Exponent : Integer) return Long_Float is
    begin
        return Mc68881.Scale (Frac (Fraction), Exponent);
    end Compose;


    function Scale (X : Long_Float;  
                    Exponent : Integer) return Long_Float is
    begin
        return Mc68881.Scale (X, Exponent);
    end Scale;


    function Floor (X : Long_Float) return Long_Float is
        Trunc : Long_Float;
    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 : Long_Float) return Long_Float is
        Trunc : Long_Float;
    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 Round (X : Long_Float) return Long_Float is
        Abs_X : Long_Float := abs X;
        Trunc, Frac : Long_Float;
    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 : Long_Float) return Long_Float 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 : Long_Float) return Long_Float is
    begin
        return X - (Y * Round (X / Y));
    end Remainder;


    function Cessor (X : Long_Float; Test : Boolean; Exp : Integer)
                    return Long_Float is
        X_Repr : Float_Representation := Conv (X);
        Bit : Integer := Mantissa_L'Last;
    begin
        loop
            X_Repr.Mantissa_Part_L (Bit) := not X_Repr.Mantissa_Part_L (Bit);
            if X_Repr.Mantissa_Part_L (Bit) = Test then
                return Conv (X_Repr);
            end if;
            Bit := Bit - 1;
            exit when Bit < Mantissa_L'First;
        end loop;
        loop
            X_Repr.Mantissa_Part_H (Bit) := not X_Repr.Mantissa_Part_H (Bit);
            if X_Repr.Mantissa_Part_H (Bit) = Test then
                return Conv (X_Repr);
            end if;
            Bit := Bit - 1;
            exit when Bit < Mantissa_H'First;
        end loop;
        return Mc68881.Scale (Conv (X_Repr), Exp);
    end Cessor;

    function Adjacent (X, Towards : Long_Float) return Long_Float is
    begin
        if X = Towards then
            return X;
        elsif X < Towards then
            return Cessor (X, True, 1);--Successor (X)
        else
            return Cessor (X, False, -1);--Predecessor (X)
        end if;
    end Adjacent;

    function Successor (X : Long_Float) return Long_Float is
    begin
        if X >= Long_Float'Last then
            raise Constraint_Error;
        end if;
        return Cessor (X, Test => True, Exp => 1);
    end Successor;


    function Predecessor (X : Long_Float) return Long_Float is
    begin
        if X <= -Long_Float'Last then
            raise Constraint_Error;
        end if;
        return Cessor (X, Test => False, Exp => -1);
    end Predecessor;


    function Copy_Sign (Value, Sign : Long_Float) return Long_Float is
        Value_Repr : Float_Representation := Conv (Value);
        Sign_Repr : Float_Representation := Conv (Sign);
    begin
        Value_Repr.Sign_Bit := Sign_Repr.Sign_Bit;
        return Conv (Value_Repr);
    end Copy_Sign;


    function Leading_Part (X : Long_Float;  
                           Radix_Digits : Positive) return Long_Float is
        X_Repr : Float_Representation := Conv (X);
        Bit : Positive := Radix_Digits;
    begin
        while Bit <= Mantissa_H'Last loop
            X_Repr.Mantissa_Part_H (Bit) := False;
            Bit := Bit + 1;
        end loop;
        while Bit <= Mantissa_L'Last loop
            X_Repr.Mantissa_Part_L (Bit) := False;
            Bit := Bit + 1;
        end loop;
        return Conv (X_Repr);
    end Leading_Part;

end Long_Primitive_Functions;
DataMuseum.dk

Rational R1000/400 Tapes

⟦73d8b862d⟧ TextFile

Derivation

TextFile
