⟦2315a125a⟧

TextFile

with Float_Operations;
with Unchecked_Conversion;
package body Primitive_Functions is

    package Mc68881 renames Float_Operations.Single;

    type Sign is new Boolean;
    for Sign'Size use 1;

    type Biased_Exponent is range 0 .. 2 ** 8 - 1;
    for Biased_Exponent'Size use 8;

    type Mantissa is array (1 .. 23) of Boolean;
    pragma Pack (Mantissa);

    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 .. 8;
            Mantissa_Part at 0 range 9 .. 31;
        end record;

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

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

    -----------
    -- 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 : Float) return Integer is
    begin
        return Integer (Mc68881.Exponent (X)) + 1;
    end Exp;

    function Frac (X : Float) return Float is
    begin
        return Mc68881.Scale (Mc68881.Mantissa (X), -1);
    end Frac;
    pragma Inline (Exp, Frac);

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

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

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


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


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


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


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


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


    function Cessor (X : Float; Test : Boolean; Exp : Integer) return Float is
        X_Repr : Float_Representation := Conv (X);
        Bit : Integer := Mantissa'Last;
    begin
        loop
            X_Repr.Mantissa_Part (Bit) := not X_Repr.Mantissa_Part (Bit);
            if X_Repr.Mantissa_Part (Bit) = Test then
                return Conv (X_Repr);
            end if;
            Bit := Bit - 1;
            if Bit < Mantissa'First then
                return Mc68881.Scale (Conv (X_Repr), Exp);
            end if;
        end loop;
    end Cessor;

    function Adjacent (X, Towards : Float) return 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 : Float) return Float is
    begin
        if X >= Float'Last then
            raise Constraint_Error;
        end if;
        return Cessor (X, Test => True, Exp => 1);
    end Successor;


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


    function Copy_Sign (Value, Sign : Float) return 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 : Float;  
                           Radix_Digits : Positive) return Float is
        X_Repr : Float_Representation := Conv (X);
    begin
        for Bit in Radix_Digits .. Mantissa'Last loop
            X_Repr.Mantissa_Part (Bit) := False;
        end loop;
        return Conv (X_Repr);
    end Leading_Part;

end Primitive_Functions;
DataMuseum.dk

Rational R1000/400 Tapes

⟦2315a125a⟧ TextFile

Derivation

TextFile
