DataMuseum.dk

top - metrics - download

    Length: 5005 (0x138d)
    Types: TextFile
    Names: »B«

└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
    └─⟦5cb1d1d7f⟧ »DATA« 
        └─⟦3b1ee7bd8⟧ 
            └─⟦this⟧ 

TextFile

with Semantic_Attributes;
with Diana;
with Action;
package body Directory_Tools is

    function "=" (S1, S2 : Dir.Error_Status) return Boolean renames Dir."=";

    function "=" (S1, S2 : Dir.Naming.Name_Status) return Boolean
        renames Dir.Naming."=";


    procedure Assert_Success (Status : Dir.Error_Status) is
    begin
        if "/=" (Status, Dir.Successful) then
            raise Failure;
        end if;
    end Assert_Success;

    procedure Assert_Success (Status : Dir.Naming.Name_Status) is
    begin
        if "/=" (Status, Dir.Naming.Successful) then
            raise Failure;
        end if;
    end Assert_Success;


    procedure Assert_Installed (Unit : Diana.Tree) is
    begin
        if not Dir.Declaration_Operations.Is_Installed (Unit) then
            raise Illegal_Operation;
        end if;
    end Assert_Installed;

    function Get_Object (Name : String) return Dir.Object is
        Status : Dir.Naming.Name_Status;
        Return_Object : Dir.Object;
    begin
        Dir.Naming.Resolve (Name, Return_Object, Status);
        Assert_Success (Status);
        return Return_Object;
    end Get_Object;

    function Get_Object (Comp_Unit : Diana.Tree) return Dir.Object is
        Status : Dir.Error_Status;
        Return_Object : Dir.Object;
    begin
        Dir.Traversal.Get_Object (Comp_Unit, Return_Object, Status);
        Assert_Success (Status);
        return Return_Object;
    end Get_Object;

    function Get_Root (Object : Dir.Object) return Diana.Tree is
        Decl : Dir.Declaration;
        Status : Dir.Error_Status;
        Root : Dir.Ada.Root;
        Key : Dir.Ada.Conversion_Key := Dir.Ada.Nil;
    begin
        Dir.Ada.Open (Dir.Ada.Get_Unit (Object), Dir.Ada.None,
                      Root, Key, Status, Action.Null_Id);
        Assert_Success (Status);
        Assert_Installed (Root);
        return Root;
    end Get_Root;

    function Get_Object_Of_Any_Node (Node : Diana.Tree) return Dir.Object is
        Unit : Dir.Ada.Unit;
        Status : Dir.Error_Status;
    begin
        Dir.Ada.Get_Unit (Node, Unit, Status);
        Assert_Success (Status);
        return Dir.Ada.Get_Object (Unit);
    end Get_Object_Of_Any_Node;

    function Objects_In_Context_Clause
                (Object : Dir.Object) return Set_Of_Objects is
        Return_Set : Object_Set.Set;
        Context_List : Diana.Seq_Type :=
           Diana.List (Diana.As_Context (Get_Root (Object)));
        Context_Elem : Diana.Tree;
        With_Ids : Diana.Seq_Type;
        An_Id : Diana.Tree;
        Withed_Unit : Diana.Tree;
    begin
        Object_Set.Initialize (Return_Set);

        while not Diana.Is_Empty (Context_List) loop
            Context_Elem := Diana.Head (Context_List);

            case Diana.Kind (Context_Elem) is
                when Diana.Dn_With =>
                    With_Ids := Diana.List (Context_Elem);

                    while not Diana.Is_Empty (With_Ids) loop
                        Withed_Unit := Diana.Sm_Defn (Diana.Head (With_Ids));
                        Object_Set.Add (Return_Set,
                                        Get_Object_Of_Any_Node (Withed_Unit));
                        With_Ids := Diana.Tail (With_Ids);
                    end loop;
                when others =>
                    null;
            end case;

            Context_List := Diana.Tail (Context_List);
        end loop;

        return Return_Set;
    end Objects_In_Context_Clause;

    function Get_Applied_Pragma
                (Node : Diana.Tree; Pragma_Name : String) return Diana.Tree is
        Pragma_List : Diana.Sequence :=
           Semantic_Attributes.Sm_Applied_Pragmas (Node);
        Next_Pragma : Diana.Tree;
    begin
        while not Diana.Is_Empty (Pragma_List) loop
            Next_Pragma := Diana.Head (Pragma_List);

            if Pragma_Name = Diana.Image (Diana.Id
                                             (Diana.As_Id (Next_Pragma))) then
                return Next_Pragma;
            end if;

            Pragma_List := Diana.Tail (Pragma_List);
        end loop;

        return Diana.Empty;
    end Get_Applied_Pragma;

    function Has_User_Seg_Number (Node : Diana.Tree) return Boolean is
    begin
        return not Diana.Is_Empty (Get_Applied_Pragma (Node, "MODULE_NAME"));
    end Has_User_Seg_Number;

    function Is_Mirror (Object : Dir.Object) return Boolean is
        Unit_Id : Diana.Tree :=
           Diana.Id_Utilities.Comp_Unit_Id (Get_Root (Object));
    begin
        return Semantic_Attributes.Has_Sm_Subsystem_Interface (Unit_Id) and then
                  Has_User_Seg_Number (Unit_Id);
    end Is_Mirror;

    function Is_Subsystem_Spec (Object : Dir.Object) return Boolean is
        Unit_Id : Diana.Tree :=
           Diana.Id_Utilities.Comp_Unit_Id (Get_Root (Object));
    begin
        return Semantic_Attributes.Has_Sm_Subsystem_Interface (Unit_Id) and then
                  not Has_User_Seg_Number (Unit_Id);
    end Is_Subsystem_Spec;
end Directory_Tools;