⟦8eabbd328⟧

TextFile

--------------------------------- COPYRIGHT ------------------------------------
-- (C) 1986 Swiss Federal Institute of Technology (EPFL).                     --
--     Represented by A. Strohmeier DMA-EPFL 1015 Lausanne Switzerland.       --
--     All Rights Reserved.                                                   --
--------------------------------------------------------------------------------

--+ TITLE:      GENERIC PACKAGE FOR QUEUES.
--+ SUPPORT:    S.R.Y. Louboutin DMA-EPFL CH-1015 Lausanne
--+ APPROVAL:   03-DEC-1987 C. Genillard.
--+ CREATION:   10-JUL-1987 A. Strohmeier.

with Unchecked_Deallocation;
package body Queue_Of_Dynamic_Items_G is

    Max_Free_List_Size : Natural := 0;

    type Free_List_Type is
        record
            Ptr : Link_Type;
            Count : Natural := 0;
        end record;

--/ STATE VARIABLE:
    Free_List : Free_List_Type;

--/ LOCAL SUBPROGRAM:
    procedure Create_And_Assign_Cell
                 (Link : in out Link_Type; Data_Value : in Item_Type) is
        -- LINK has in (out) mode for allowing access to LINK.VALUE.
    begin
        if Free_List.Count = 0 then
            Link := new Cell_Type;
        else
            Link := Free_List.Ptr;
            Free_List.Ptr := Free_List.Ptr.Next;
            Free_List.Count := Free_List.Count - 1;
            Link.Next := null;
        end if;
        Assign (Link.Value, Data_Value);
    end Create_And_Assign_Cell;
    pragma Inline (Create_And_Assign_Cell);

--/ LOCAL SUBPROGRAM:
    procedure Dispose is new Unchecked_Deallocation
                                (Object => Cell_Type, Name => Link_Type);
    pragma Inline (Dispose);

--/ LOCAL SUBPROGRAM:
    procedure Release (Link : in out Link_Type) is
    begin
        Destroy (Link.Value);
        if Free_List.Count < Max_Free_List_Size then
            Link.Next := Free_List.Ptr;
            Free_List.Ptr := Link;
            Free_List.Count := Free_List.Count + 1;
        else
            Dispose (Link);
        end if;
    end Release;
    pragma Inline (Release);


--/ CONSTRUCTORS:

    procedure Assign (Destination : in out Queue_Type;
                      Source : in Queue_Type) is
        Current_Source_Ptr : Link_Type;
        Current_Dest_Ptr : Link_Type;
    begin
        if Destination.First = Source.First then
            return;
        end if;
        -- Actual parameters are identical queues.
        Destroy (Destination);
        if Source.Count = 0 then
            return;
        end if;
        -- SOURCE is a null queue.
        Create_And_Assign_Cell (Destination.First, Source.First.Value);
        Current_Dest_Ptr := Destination.First;
        Current_Source_Ptr := Source.First.Next;
        while Current_Source_Ptr /= null loop
            Create_And_Assign_Cell (Current_Dest_Ptr.Next,
                                    Current_Source_Ptr.Value);
            Current_Dest_Ptr := Current_Dest_Ptr.Next;
            Current_Source_Ptr := Current_Source_Ptr.Next;
        end loop;
        Destination.Last := Current_Dest_Ptr;
        Destination.Count := Source.Count;
    end Assign;

    procedure Insert (Queue : in out Queue_Type; Item : in Item_Type) is
        Temp : Link_Type;
    begin
        Create_And_Assign_Cell (Temp, Item);
        if Queue.Count = 0 then
            Queue.First := Temp;
        else
            Queue.Last.Next := Temp;
        end if;
        Queue.Last := Temp;
        Queue.Count := Queue.Count + 1;
    end Insert;

--/ LOCAL SUBPROGRAM:
    procedure Remove_First_Cell (Queue : in out Queue_Type) is
        -- Removes and releases the first cell from the queue.
        Temp : Link_Type := Queue.First;
    begin
        Queue.First := Queue.First.Next;
        Queue.Count := Queue.Count - 1;
        Release (Temp);
    end Remove_First_Cell;
    pragma Inline (Remove_First_Cell);

    procedure Remove (Queue : in out Queue_Type) is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Remove_First_Cell (Queue);
    end Remove;

    procedure Remove (Queue : in out Queue_Type; Item : in out Item_Type) is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Assign (Item, Queue.First.Value);
        -- no call to DESTROY before ASSIGN.
        Remove_First_Cell (Queue);
    end Remove;

--/ QUERIES:

    function "=" (Left, Right : Queue_Type) return Boolean is
        Pointer_To_L_Item : Link_Type := Left.First;
        Pointer_To_R_Item : Link_Type := Right.First;
    begin
        if Left.Count /= Right.Count then
            return False;
        end if;
        while Pointer_To_L_Item /= null loop
            if not Equals (Pointer_To_L_Item.Value,
                           Pointer_To_R_Item.Value) then
                return False;
            end if;
            Pointer_To_L_Item := Pointer_To_L_Item.Next;
            Pointer_To_R_Item := Pointer_To_R_Item.Next;
        end loop;
        return True;
    end "=";

    function First_Value (Queue : Queue_Type) return Item_Type is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        return Queue.First.Value;
    end First_Value;

    procedure Get_First_Value (Queue : in Queue_Type;
                               Item : in out Item_Type) is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Assign (Item, Queue.First.Value);
        -- No call to DESTROY before ASSIGN !
    end Get_First_Value;

    function Last_Value (Queue : Queue_Type) return Item_Type is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        return Queue.Last.Value;
    end Last_Value;

    procedure Get_Last_Value (Queue : in Queue_Type; Item : in out Item_Type) is
    begin
        if Queue.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Assign (Item, Queue.Last.Value);
        -- No call to DESTROY before ASSIGN !
    end Get_Last_Value;

    function Is_Empty (Queue : Queue_Type) return Boolean is
    begin
        return Queue.Count = 0;
    end Is_Empty;

    function Size (Queue : Queue_Type) return Natural is
    begin
        return Queue.Count;
    end Size;

--/ ITERATORS:

    procedure Traverse_G (Queue : in Queue_Type) is
        Temp : Link_Type := Queue.First;
        Continue : Boolean := True;
    begin
        for Counter in 1 .. Queue.Count loop
            Action (Temp.Value, Counter, Continue);
            exit when not Continue;
            Temp := Temp.Next;
        end loop;
    end Traverse_G;

--/ HEAP MANAGEMENT:

    procedure Destroy (Queue : in out Queue_Type) is
        Temp : Link_Type := Queue.First;
        Next : Link_Type;
    begin
        while Temp /= null loop
            Next := Temp.Next;
            Release (Temp);
            Temp := Next;
        end loop;
        Queue := (null, null, 0);
    end Destroy;

    procedure Release_Free_List is
        Temp : Link_Type;
    begin
        while Free_List.Ptr /= null loop
            Temp := Free_List.Ptr;
            Free_List.Ptr := Free_List.Ptr.Next;
            Dispose (Temp);
        end loop;
        Free_List.Count := 0;
    end Release_Free_List;

    procedure Set_Max_Free_List_Size (Max_Free_List_Size : in Natural) is
        Nb_Of_Cells_For_System : Integer :=
           Free_List.Count - Max_Free_List_Size;
        Temp : Link_Type;
    begin
        if Nb_Of_Cells_For_System > 0 then
            for I in 1 .. Nb_Of_Cells_For_System loop
                Temp := Free_List.Ptr;
                Free_List.Ptr := Free_List.Ptr.Next;
                Dispose (Temp);
            end loop;
            Free_List.Count := Free_List.Count - Nb_Of_Cells_For_System;
        end if;
        Queue_Of_Dynamic_Items_G.Max_Free_List_Size := Max_Free_List_Size;
    end Set_Max_Free_List_Size;

    function Free_List_Size return Natural is
    begin
        return Free_List.Count;
    end Free_List_Size;

end Queue_Of_Dynamic_Items_G;
DataMuseum.dk

Rational R1000/400 Tapes

⟦8eabbd328⟧ TextFile

Derivation

TextFile
