⟦01662322e⟧

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 STACKS.
--+ 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 Stack_Of_Static_Items_G is

--/ LOCAL SUBPROGRAM:
    procedure Assign_Item (Destination : out Item_Type; Source : in Item_Type);
    procedure Assign (Destination : out Item_Type; Source : in Item_Type)
        renames Assign_Item;

--/ LOCAL SUBPROGRAM:
    procedure Destroy_Item (Item : in Item_Type);
    procedure Destroy (Item : in Item_Type) renames Destroy_Item;


    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 Stack_Type;
                      Source : in Stack_Type) is
        Current_Source_Ptr : Link_Type;
        Current_Dest_Ptr : Link_Type;
    begin
        if Source.Top = Destination.Top then
            return;
        end if;
        -- Actual parameters are identical stacks.
        Destroy (Destination);
        if Source.Count = 0 then
            return;
        end if;
        -- SOURCE is a null stack.
        Create_And_Assign_Cell (Destination.Top, Source.Top.Value);
        Current_Dest_Ptr := Destination.Top;
        Current_Source_Ptr := Source.Top.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.Count := Source.Count;
    end Assign;

--/ LOCAL SUBPROGRAM:
    procedure Remove_Top_Cell (Stack : in out Stack_Type) is
        -- Removes and releases cell on top of stack.
        Temp : Link_Type := Stack.Top;
    begin
        Stack.Top := Stack.Top.Next;
        Stack.Count := Stack.Count - 1;
        Release (Temp);
    end Remove_Top_Cell;
    pragma Inline (Remove_Top_Cell);

    procedure Pop (Stack : in out Stack_Type) is
    begin
        if Stack.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Remove_Top_Cell (Stack);
    end Pop;

    procedure Pop (Stack : in out Stack_Type; Item : out Item_Type) is
    begin
        if Stack.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Assign (Item, Stack.Top.Value);
        -- no call to DESTROY before ASSIGN
        Remove_Top_Cell (Stack);
    end Pop;

    procedure Push (Stack : in out Stack_Type; Item : in Item_Type) is
        Temp : Link_Type;
    begin
        Create_And_Assign_Cell (Temp, Item);
        Temp.Next := Stack.Top;
        Stack.Top := Temp;
        Stack.Count := Stack.Count + 1;
    end Push;

--/ QUERIES:

    function "=" (Left, Right : in Stack_Type) return Boolean is
        Pointer_To_L_Item : Link_Type := Left.Top;
        Pointer_To_R_Item : Link_Type := Right.Top;
    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 Top_Value (Stack : in Stack_Type) return Item_Type is
    begin
        if Stack.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        return Stack.Top.Value;
    end Top_Value;

    procedure Get_Top_Value (Stack : in Stack_Type; Item : out Item_Type) is
    begin
        if Stack.Count = 0 then
            raise Empty_Structure_Error;
        end if;
        Assign (Item, Stack.Top.Value);
        -- No call to DESTROY before ASSIGN !
    end Get_Top_Value;

    function Is_Empty (Stack : in Stack_Type) return Boolean is
    begin
        return Stack.Count = 0;
    end Is_Empty;

    function Size (Stack : in Stack_Type) return Natural is
    begin
        return Stack.Count;
    end Size;

--/ ITERATORS:

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

--/ HEAP MANAGEMENT:

    procedure Destroy (Stack : in out Stack_Type) is
        Temp : Link_Type := Stack.Top;
        Next : Link_Type;
    begin
        while Temp /= null loop
            Next := Temp.Next;
            Release (Temp);
            Temp := Next;
        end loop;
        Stack := (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;
        Stack_Of_Static_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;

    procedure Assign_Item (Destination : out Item_Type;
                           Source : in Item_Type) is
    begin
        Destination := Source;
    end Assign_Item;

    procedure Destroy_Item (Item : in Item_Type) is
        -- Mode of the parameter is artificial, but mode 'out' could raise
        -- CONSTRAINT_ERROR !
    begin
        null;
    end Destroy_Item;
    pragma Inline (Assign_Item);
    pragma Inline (Destroy_Item);


end Stack_Of_Static_Items_G;
DataMuseum.dk

Rational R1000/400 Tapes

⟦01662322e⟧ TextFile

Derivation

TextFile
