⟦cd19fc800⟧

TextFile

with Unchecked_Deallocation;

package body Dynarray_Pkg is

    -- Utilities:

    procedure Free_Array_Ptr is
       new Unchecked_Deallocation (Array_Type, Array_Ptr);

    procedure Free_Darray is new Unchecked_Deallocation (Darray_Info, Darray);

    function Down_Index (I : in Integer; D : in Darray) return Integer;

    --| Raises: out_of_bounds
    --| Effects:
    --| Map from abstraction indices to representation indices.
    --| Raises out_of_bounds iff either is_empty(d) or i is not in
    --| d.first..last(d).
    --| Requires: d must be initialized.

    procedure Initialization_Check (D : in Darray);

    --| Raises: uninitialized_darray
    --| Effects:
    --| Returns normally iff d has been the target of a create, copy,
    --| or array_to_darray operation, and has not since been destroyed.
    --| Otherwise, raises uninitialized_darray.
    --| This procedure will not detect the case where another object
    --| sharing the same darray value has been destroyed; this is
    --| erroneous use.

    procedure Expand (D : in out Darray);

    --| Effects:
    --| Allocates additional space in d.arr.  The old contents of d.arr
    --| are copied to a slice of the new array.  The expansion amount is
    --| a percentage (d.expand_percent) of currently allocated space.
    --| Sets d.first_idx and d.last_idx to appropriate positions in the
    --| new array; these positions are selected according to the
    --| expected distribution of add_highs/add_lows (d.high_percent).
    --| Requires: d must be initialized.

    procedure Contract (D : in out Darray);

    --| Effects:
    --| Checks whether d.arr consumes too much space in proportion to
    --| the slice that is being used to hold the darray elements.  If
    --| so, halves the size of d.arr.  The old contents of d.arr are
    --| copied to a slice of the new array.  Sets d.first_idx and
    --| and d.last_idx to appropriate positions in the new array; these
    --| positions are selected according to the expected distribution of
    --| add_highs/add_lows (d.high_percent).
    --| Requires: d must be initialized and nonempty.

    procedure Reallocate (D : in out Darray; New_Length : in Positive);

    --| Raises: out_of_bounds
    --| Effects:
    --| Replaces d.arr with a pointer to an array of length new_length,
    --| fills a slice of this array with the old contents of d.arr, and
    --| adjusts d.first_idx and d.last_idx appropriately.  Everything is
    --| done according to d.high_percent.  Used by both expand/contract.
    --| Raises out_of_bounds iff new_length < length(d).
    --| Requires: d must be initialized.

    procedure Determine_Position (Array_Length : in Positive;
                                  Slice_Length : in Natural;
                                  High_Percent : in Positive;
                                  First_Idx : out Positive;
                                  Last_Idx : out Natural);

    --| Raises: out_of_bounds
    --| Effects:
    --| Determines the appropriate position of a slice of length
    --| slice_length in an array with range 1..array_length.  This
    --| position is calculated according to the high_percent parameter.
    --| Raises out_of_bounds iff slice_length > array_length.
    --| Used by create, array_to_darray, reallocate.


    -- Constructors:

    procedure Create (First : in Integer := 1;
                      Predict : in Positive := Default_Predict;
                      High_Percent : in Positive := Default_High;
                      Expand_Percent : in Positive := Default_Expand;
                      D : in out Darray) is
    begin
        Destroy (D);
        D := new Darray_Info;
        Determine_Position (Predict, 0, High_Percent, D.First_Idx, D.Last_Idx);
        D.First := First;
        D.High_Percent := High_Percent;
        D.Expand_Percent := Expand_Percent;
        D.Arr := new Array_Type (1 .. Predict);
    exception
        when Out_Of_Bounds =>

            -- determine_position fails
            Destroy (D);
            raise;
    end Create;

    procedure Array_To_Darray (A : in Array_Type;
                               First : in Integer := 1;
                               Predict : in Positive;
                               High_Percent : in Positive := Default_High;
                               Expand_Percent : in Positive := Default_Expand;
                               D : in out Darray) is
    begin
        if D /= null then
            Free_Array_Ptr (D.Arr);
        end if;
        D := new Darray_Info;
        Determine_Position (Predict, A'Length, High_Percent,
                            D.First_Idx, D.Last_Idx);
        D.First := First;
        D.High_Percent := High_Percent;
        D.Expand_Percent := Expand_Percent;
        D.Arr := new Array_Type (1 .. Predict);
        D.Arr.all := A;
    exception
        when Out_Of_Bounds =>

            -- determine_position fails
            Destroy (D);
            raise;
    end Array_To_Darray;

    procedure Set_First (D : in out Darray; First : in Integer) is
    begin
        Initialization_Check (D);
        D.First := First;
    end Set_First;

    procedure Add_Low (D : in out Darray; E : in Elem_Type) is
    begin
        Initialization_Check (D);
        D.Arr (D.First_Idx - 1) := E;
        D.First_Idx := D.First_Idx - 1;
        D.First := D.First - 1;
    exception
        when Constraint_Error =>

            -- on array store
            Expand (D);
            D.Arr (D.First_Idx - 1) := E;
            D.First_Idx := D.First_Idx - 1;
            D.First := D.First - 1;
    end Add_Low;

    procedure Add_High (D : in out Darray; E : in Elem_Type) is
    begin
        Initialization_Check (D);
        D.Arr (D.Last_Idx + 1) := E;
        D.Last_Idx := D.Last_Idx + 1;
    exception
        when Constraint_Error =>

            -- on array store
            Expand (D);
            D.Arr (D.Last_Idx + 1) := E;
            D.Last_Idx := D.Last_Idx + 1;
    end Add_High;

    procedure Remove_Low (D : in out Darray) is
    begin
        Initialization_Check (D);
        if D.Last_Idx < D.First_Idx then
            raise Out_Of_Bounds;
        end if;

        D.First_Idx := D.First_Idx + 1;
        D.First := D.First + 1;
        Contract (D);
    end Remove_Low;

    procedure Remove_High (D : in out Darray) is
    begin
        Initialization_Check (D);
        if D.Last_Idx < D.First_Idx then
            raise Out_Of_Bounds;
        end if;

        D.Last_Idx := D.Last_Idx - 1;
        Contract (D);
    end Remove_High;

    procedure Store (D : in out Darray; I : in Integer; E : in Elem_Type) is
    begin
        Initialization_Check (D);
        D.Arr (Down_Index (I, D)) := E;
    end Store;

    function Copy (D : in Darray) return Darray is
        D2 : Darray;
    begin
        Initialization_Check (D);
        D2 := new Darray_Info'(First_Idx => D.First_Idx,
                               Last_Idx => D.Last_Idx,
                               First => D.First,
                               High_Percent => D.High_Percent,
                               Expand_Percent => D.Expand_Percent,
                               Arr => new Array_Type (1 .. D.Arr'Length));
        D2.Arr.all := D.Arr.all;
        return D2;
    end Copy;

    function Copy_Deep (D : in Darray) return Darray is
        D2 : Darray;
        I : Integer;
    begin
        Initialization_Check (D);
        D2 := new Darray_Info'(First_Idx => D.First_Idx,
                               Last_Idx => D.Last_Idx,
                               First => D.First,
                               High_Percent => D.High_Percent,
                               Expand_Percent => D.Expand_Percent,
                               Arr => new Array_Type (1 .. D.Arr'Length));
        for I in D.First_Idx .. D.Last_Idx loop
            D2.Arr (I) := Copy (D.Arr (I));
        end loop;
        return D2;
    end Copy_Deep;


    -- Query Operations:

    function Fetch (D : in Darray; I : in Integer) return Elem_Type is
    begin
        Initialization_Check (D);
        return D.Arr (Down_Index (I, D));
    end Fetch;

    function Low (D : in Darray) return Elem_Type is
    begin
        Initialization_Check (D);
        return D.Arr (Down_Index (D.First, D));
    end Low;

    function High (D : in Darray) return Elem_Type is
    begin
        if Is_Empty (D) then

            -- is_empty checks for initialization
            raise Out_Of_Bounds;
        end if;
        return D.Arr (D.Last_Idx);
    end High;

    function First (D : in Darray) return Integer is
    begin
        Initialization_Check (D);
        return D.First;
    end First;

    function Last (D : in Darray) return Integer is
    begin
        Initialization_Check (D);
        return D.First + D.Last_Idx - D.First_Idx;
    end Last;

    function Is_Empty (D : in Darray) return Boolean is
    begin
        Initialization_Check (D);
        return D.Last_Idx < D.First_Idx;
    end Is_Empty;

    function Length (D : in Darray) return Natural is
    begin
        Initialization_Check (D);
        return D.Last_Idx - D.First_Idx + 1;
    end Length;

    function Equal (D1, D2 : in Darray) return Boolean is
        I2 : Integer;
    begin
        Initialization_Check (D1);
        Initialization_Check (D2);

        if D1.First /= D2.First or else Length (D1) /= Length (D2) then
            return False;
        end if;

        I2 := D2.First_Idx;
        for I1 in D1.First_Idx .. D1.Last_Idx loop
            if not Equal (D1.Arr (I1), D2.Arr (I2)) then
                return False;
            end if;
            I2 := I2 + 1;
        end loop;

        return True;
    end Equal;

    function Darray_To_Array (D : in Darray) return Array_Type is
        subtype Dbounds_Array is Array_Type (D.First .. Last (D));
        -- invocation of last performs initialization check.
    begin
        return Dbounds_Array'(D.Arr (D.First_Idx .. D.Last_Idx));
    end Darray_To_Array;


    -- Iterators:

    function Make_Elements_Iter (D : in Darray) return Elements_Iter is
    begin
        Initialization_Check (D);
        return (Current => D.First_Idx, Last => D.Last_Idx, Arr => D.Arr);
    end Make_Elements_Iter;

    function More (Iter : in Elements_Iter) return Boolean is
    begin
        return Iter.Current <= Iter.Last;
    end More;

    procedure Next (Iter : in out Elements_Iter; E : out Elem_Type) is
    begin
        if not More (Iter) then
            raise No_More;
        end if;

        E := Iter.Arr (Iter.Current);
        Iter.Current := Iter.Current + 1;
    end Next;


    -- Heap Management:

    procedure Destroy (D : in out Darray) is
    begin
        Free_Array_Ptr (D.Arr);
        Free_Darray (D);
    exception
        when Constraint_Error =>

            -- d is null, d.arr is illegal.
            return;
    end Destroy;


    -- Utilities:

    function Down_Index (I : in Integer; D : in Darray) return Integer is
        Down_Idx : Integer := I - D.First + D.First_Idx;
    begin
        if D.Last_Idx < D.First_Idx or else

           -- empty array
           not (Down_Idx in D.First_Idx .. D.Last_Idx) then

            -- bogus index
            raise Out_Of_Bounds;
        end if;

        return Down_Idx;
    end Down_Index;

    procedure Initialization_Check (D : in Darray) is
    begin
        if D = null then
            raise Uninitialized_Darray;
        end if;
    end Initialization_Check;

    procedure Expand (D : in out Darray) is
        New_Length : Integer := (D.Arr'Length * (100 + D.Expand_Percent)) / 100;
    begin

        -- Specified percent, in relation to length, may be too small to
        -- force any growth.  In this case, force growth.  This is rare.
        -- The choice to double is arbitrary.
        if New_Length = D.Arr'Length then
            New_Length := 2 * D.Arr'Length;
        end if;

        Reallocate (D, New_Length);
    end Expand;

    procedure Contract (D : in out Darray) is
        -- <<A better contraction strategy is needed.  Justification is weak
        -- for this one.>>
    begin
        null;
    end Contract;

    procedure Reallocate (D : in out Darray; New_Length : in Positive) is

        New_Arr : Array_Ptr;
        New_First_Idx : Integer;
        New_Last_Idx : Integer;

    begin
        Determine_Position (New_Length, Length (D), D.High_Percent,
                            New_First_Idx, New_Last_Idx);
        New_Arr := new Array_Type (1 .. New_Length);
        New_Arr (New_First_Idx .. New_Last_Idx) :=
           D.Arr (D.First_Idx .. D.Last_Idx);
        Free_Array_Ptr (D.Arr);
        D.Arr := New_Arr;
        D.First_Idx := New_First_Idx;
        D.Last_Idx := New_Last_Idx;
    end Reallocate;

    procedure Determine_Position (Array_Length : in Positive;
                                  Slice_Length : in Natural;
                                  High_Percent : in Positive;
                                  First_Idx : out Positive;
                                  Last_Idx : out Natural) is

        Left_Over : Integer := Array_Length - Slice_Length;
        High_Space : Integer := (High_Percent * Left_Over) / 100;
        Low_Space : Integer := Left_Over - High_Space;

    begin
        if Left_Over < 0 then
            raise Out_Of_Bounds;
        end if;

        First_Idx := Low_Space + 1;
        Last_Idx := Low_Space + Slice_Length;
    end Determine_Position;

end Dynarray_Pkg;
DataMuseum.dk

Rational R1000/400 Tapes

⟦cd19fc800⟧ TextFile

Derivation

TextFile
