⟦df6f6c6e3⟧

E3 Source Code



with Log;
package body Lists is

    First_Position : constant Natural := Natural (Positions'First);
    Done_Position  : constant Natural := Natural'Pred (First_Position);

    procedure Set (This_Pointer     : in out Pointer;
                   To_This_Position : in     Positions;
                   In_This_List     : in out List;
                   Permanently      :        Boolean := False) is
        --
        Final_Position : Natural := Natural (To_This_Position) - First_Position;
        --
    begin
        This_Pointer := In_This_List.First;
        for Counter in First_Position .. Final_Position loop
            This_Pointer := This_Pointer.Next;
        end loop;
        if (Permanently) then
            In_This_List.Current  := This_Pointer;
            In_This_List.Position := Final_Position;
        end if;
    end Set;

    function Create return List is
        --
        The_List : List;
        --
    begin  
        return (The_List);  
    end Create;

    function Is_Empty (This_List : in List) return Boolean is  
    begin  
        return (Elements_In (This_List) = 0);  
    end Is_Empty;

    function Elements_In (This_List : in List) return Natural is  
    begin  
        return (This_List.Count);  
    end Elements_In;

    function Copy (Of_List : in List) return List is
        --
        Current : Pointer := Of_List.First;
        --
        New_List : List := Create;
        --
    begin
        while (not (Current = null)) loop
            Add (New_List, Copy (Current.Contents));
            Current := Current.Next;
        end loop;  
        if (not Done (Of_List)) then
            Set (New_List, Position (Of_List));
        end if;
        return (New_List);
    end Copy;

    procedure Reset (This_List : in out List) is  
    begin  
        This_List.Current := This_List.First;
        if (This_List.First = null) then
            This_List.Position := Done_Position;
        else
            This_List.Position := First_Position;
        end if;
    end Reset;

    function Done (This_List : in List) return Boolean is
    begin
        return (This_List.Current = null);
    end Done;

    procedure Next (This_List : in out List) is  
    begin
        This_List.Current  := This_List.Current.Next;
        This_List.Position := This_List.Position + 1;
        --
    exception
        when Constraint_Error =>
            This_List.Position := Done_Position; -- Reset position.
            raise No_Next_Element;
            --
    end Next;

    function Current (This_List : in List) return Element is  
    begin  
        return (This_List.Current.Contents);
        --
    exception
        when Constraint_Error =>
            raise No_Current_Element;
            --
    end Current;

    function Position (In_List : in List) return Positions is
    begin
        return (ositions (In_List.Position));
        --
    exception
        when Constraint_Error =>
            raise No_Current_Element;
            --
    end Position;

    procedure Set (This_List : in out List; To_Position : in Positions) is
    begin  
        Set (This_List.Current, To_Position, This_List, Permanently => True);
        --
    exception
        when Constraint_Error =>
            raise Out_Of_Range;
            --
    end Set;

    function Element_At (This_Position : in Positions; In_List : in List)
                        return Element is
        --
        The_List : List := In_List;
        --
        Probe : Pointer := null;
        --
    begin
        Set (Probe, This_Position, The_List);
        return (Probe.Contents);
        --
    exception
        when Constraint_Error =>
            raise Out_Of_Range;
            --
    end Element_At;

    procedure Add (To_List      : in out List;  
                   This_Element : in     Element) is
        --
        New_Node : Pointer := new Node'(Contents => This_Element,  
                                        Next     => null);
        --
    begin  
        if (Is_Empty (To_List)) then  
            To_List.Position := First_Position;
            To_List.Current  := New_Node;
            To_List.First    := New_Node;  
            To_List.Last     := New_Node;
            To_List.Count    := 1;
        else  
            To_List.Last.Next := New_Node;
            To_List.Last      := New_Node;  
            To_List.Count     := To_List.Count + 1;
        end if;  
    end Add;

    procedure Modify (This_List : in out List; New_Element : in Element) is
    begin  
        This_List.Current.Contents := New_Element;
        --
    exception
        when Constraint_Error =>
            raise No_Current_Element;
            --
    end Modify;


    function Exists (In_This_List : List; This_Element : Element)
                    return Boolean is

    begin
        for Cur_Pos in 1 .. In_This_List.Count loop
            if This_Element = Element_At (This_Position => Positions (Cur_Pos),
                                          In_List       => In_This_List) then
                return True;  
            end if;  
        end loop;
        return False;
    end Exists;


    procedure Insert (To_List              : in out List;
                      This_Element         : in     Element;
                      Before_This_Position : in     Positions) is
        New_Element : Pointer := new Node'(This_Element, null);
        Temp_Ptr    : Pointer := null;

    begin  
        if Before_This_Position = 1 then  
            New_Element.Next := To_List.First;
            To_List.First    := New_Element;  
        else
            Set (Temp_Ptr, Before_This_Position - 1, To_List);
            if Temp_Ptr = To_List.Last then
                To_List.Last := New_Element;
            end if;
            New_Element.Next := Temp_Ptr.Next;
            Temp_Ptr.Next    := New_Element;  
        end if;  
        To_List.Count := To_List.Count + 1;
    end Insert;
end Lists;
DataMuseum.dk

Rational R1000/400

⟦df6f6c6e3⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
