⟦402829b92⟧

E3 Source Code



package body Hierarchy_Generic is

    function Location (Of_This_Element : Element; In_This_Hierarchy : Hier)
                      return Hier_Ptr is
        Search_Ptr : Hier_Ptr := In_This_Hierarchy.First;
    begin
        while Search_Ptr /= null loop
            if Are_Equal (Search_Ptr.Contents, Of_This_Element) then
                return Search_Ptr;
            end if;
            Search_Ptr := Search_Ptr.Next;
        end loop;  
        return null;
    end Location;


    function Create return Hier is
    begin
        return (True, null, null);
    end Create;



    procedure Add (This_Element      :        Element;
                   To_This_Hierarchy : in out Hier;
                   Element_Location  : out    Hier_Ptr) is
        New_Node     : Hier_Ptr;
        The_Location : Hier_Ptr := Location
                                      (Of_This_Element   => This_Element,
                                       In_This_Hierarchy => To_This_Hierarchy);
    begin
        if The_Location = null then
            New_Node := new Hier_Node'(Contents  => This_Element,
                                       Is_Marked => False,
                                       Parents   => Ptr_Lists.Create,
                                       Children  => Ptr_Lists.Create,
                                       Next      => null);
            if To_This_Hierarchy.First = null then   -- empty list
                To_This_Hierarchy.First := New_Node;
                To_This_Hierarchy.Last  := New_Node;
            else
                To_This_Hierarchy.Last.Next := New_Node;
                To_This_Hierarchy.Last      := New_Node;
            end if;
            Element_Location := New_Node;
        else
            Element_Location := The_Location;
        end if;
    end Add;


    procedure Add (This_Parent       :        Element;
                   And_This_Child    :        Element;
                   To_This_Hierarchy : in out Hier) is
        Parent_Ptr, Child_Ptr : Hier_Ptr;
    begin
        if not To_This_Hierarchy.Initialized then
            raise Hierarchy_Not_Initialized;
        end if;
        Add (This_Parent, To_This_Hierarchy, Parent_Ptr);
        Add (And_This_Child, To_This_Hierarchy, Child_Ptr);
        if not Ptr_Lists.Exists (In_This_List => Parent_Ptr.Children,
                                 This_Element => Child_Ptr) then
            Ptr_Lists.Add (To_List      => Parent_Ptr.Children,
                           This_Element => Child_Ptr);
            Ptr_Lists.Add (To_List      => Child_Ptr.Parents,
                           This_Element => Parent_Ptr);
        end if;
    end Add;


    procedure Mark_Element (This_Element      :        Element;
                            In_This_Hierarchy : in out Hier) is
        The_Element : Hier_Ptr;
    begin
        Add (This_Element, In_This_Hierarchy, The_Element);
        The_Element.Is_Marked := True;
    end Mark_Element;


    function Element_Is_Marked
                (This_Element : Element; In_This_Hierarchy : Hier)
                return Boolean is
        The_Element : Hier_Ptr := Location
                                     (Of_This_Element   => This_Element,
                                      In_This_Hierarchy => In_This_Hierarchy);
    begin
        if The_Element /= null then
            return The_Element.Is_Marked;
        else
            return False;
        end if;
    end Element_Is_Marked;



    function Map_From
                (This_Element : Element; In_This_Hierarchy : Hier) return Map is
        Num_Parents  : Natural  := 0;
        Num_Children : Natural  := 0;
        Record_Size  : Natural  := 0;
        Element_Ptr  : Hier_Ptr := Location
                                      (Of_This_Element   => This_Element,
                                       In_This_Hierarchy => In_This_Hierarchy);
    begin
        Ptr_Lists.Reset (Element_Ptr.Parents);
        while not Ptr_Lists.Done (Element_Ptr.Parents) loop
            Num_Parents := Num_Parents + 1;
            Ptr_Lists.Next (Element_Ptr.Parents);
        end loop;
        Ptr_Lists.Reset (Element_Ptr.Children);
        while not Ptr_Lists.Done (Element_Ptr.Children) loop
            Num_Children := Num_Children + 1;
            Ptr_Lists.Next (Element_Ptr.Children);
        end loop;
        if Num_Children > Num_Parents then
            Record_Size := Num_Children;
        else
            Record_Size := Num_Parents;
        end if;

        declare
            The_Map : Map (Record_Size);
        begin
            The_Map.Current := Element_Ptr.Contents;

            --
            --  set the parents
            --
            The_Map.Num_Parents := Num_Parents;
            Ptr_Lists.Reset (Element_Ptr.Parents);
            for This_Parent in 1 .. Num_Parents loop
                The_Map.Parents (This_Parent) :=
                   Ptr_Lists.Current (Element_Ptr.Parents).Contents;
                Ptr_Lists.Next (Element_Ptr.Parents);
            end loop;

            --
            --  set the children
            --
            The_Map.Num_Children := Num_Children;
            Ptr_Lists.Reset (Element_Ptr.Children);
            for This_Child in 1 .. Num_Children loop
                The_Map.Children (This_Child) :=
                   Ptr_Lists.Current (Element_Ptr.Children).Contents;
                Ptr_Lists.Next (Element_Ptr.Children);
            end loop;

            return The_Map;
        end;
    end Map_From;
end Hierarchy_Generic;
DataMuseum.dk

Rational R1000/400

⟦402829b92⟧ Ada Source

Derivation

E3 Source Code

E3 Meta Data
