DataMuseum.dk Presents historical artifacts from the history of: Rational R1000/400

This is an automatic "excavation" of a thematic subset of artifacts from Datamuseum.dk's BitArchive. See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software.

top - metrics - download

⟦44fff1eff⟧ Ada Source

    Length: 14336 (0x3800)
    Types: Ada Source
    Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Ada, seg_0045ad, separate Object_Info

Derivation

└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
    └─⟦cfc2e13cd⟧ »Space Info Vol 2« 
        └─⟦this⟧ 

separate (Object_Info)
package body Ada is

    function Is_Installed (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Any.Is_Ada_Unit (This_Unit) and then
                  Directory_Tools.Ada_Object.State (This_Unit) =
                     Directory_Tools.Ada_Object.Installed;
    end Is_Installed;

    function Is_Coded (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Any.Is_Ada_Unit (This_Unit) and then
                  Directory_Tools.Ada_Object.State (This_Unit) =
                     Directory_Tools.Ada_Object.Coded;
    end Is_Coded;

    function Is_Installed_Or_Coded (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Directory_Tools.Ada_Object.State (This_Unit) =
                  Directory_Tools.Ada_Object.Installed or else
               Directory_Tools.Ada_Object.State (This_Unit) =
                  Directory_Tools.Ada_Object.Coded;
    end Is_Installed_Or_Coded;

    function Is_Body (This_Unit : in Ada_Unit) return Boolean is

        Unit_Kind : Directory_Tools.Ada_Object.Unit_Kind :=
           Directory_Tools.Ada_Object.Kind (This_Unit);

    begin
        return Any.Is_Ada_Unit (This_Unit) and then
                  not Ada.Is_Subunit (This_Unit) and then
                  (Unit_Kind = Directory_Tools.Ada_Object.Package_Body or else
                   Unit_Kind = Directory_Tools.Ada_Object.Procedure_Body or else
                   Unit_Kind = Directory_Tools.Ada_Object.Function_Body);
    end Is_Body;

    function Is_Subunit (This_Unit : in Ada_Unit) return Boolean is

        Compilation_Kind : Directory_Tools.Ada_Object.Compilation_Kind :=
           Directory_Tools.Ada_Object.Kind (This_Unit);

    begin
        return Any.Is_Ada_Unit (This_Unit) and then
                  Compilation_Kind = Directory_Tools.Ada_Object.Subunit;
    end Is_Subunit;

    function Is_Body_Or_Subunit (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Ada.Is_Body (This_Unit) or else Ada.Is_Subunit (This_Unit);
    end Is_Body_Or_Subunit;

    function Is_Spec (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Any.Is_Ada_Unit (This_Unit) and then
                  Directory_Tools.Ada_Object.Is_Visible_Part (This_Unit);
    end Is_Spec;

    function Is_Universe_Mirror (This_Unit : in Ada_Unit) return Boolean is

        The_Root   : Standard.Directory.Ada.Root;
        The_Status : Standard.Directory.Error_Status;  
        Object_Id  : Diana.Tree;
        Pragmas    : Diana.Sequence;

    begin  
        if Ada.Is_Spec (This_Unit) then
            -- Find the root of the object.
            Directory_Tools.Object.Low_Level.Get_Root
               (This_Unit, The_Root, The_Status);
            -- Get the id for the object.
            Object_Id := Diana.Id_Utilities.Comp_Unit_Id (The_Root);
            if Semantic_Attributes.Has_Sm_Subsystem_Interface (Object_Id) then
                -- Since is subsystem interface, see if has a pragma
                -- for Module_Name in it: if so, it is a universe mirror.
                Pragmas := Semantic_Attributes.Sm_Applied_Pragmas (Object_Id);
                while not Diana.Is_Empty (Pragmas) loop
                    if String_Utilities.Upper_Case
                          (Diana.Image (Diana.Id
                                           (Diana.As_Id (Diana.Head
                                                            (Pragmas))))) =
                       "MODULE_NAME" then
                        return True;
                    end if;
                    Pragmas := Diana.Tail (Pragmas);
                end loop;  
            end if;  
        end if;
        return False;

    exception
        when others =>
            return False;

    end Is_Universe_Mirror;

    function Is_Generic_Spec (This_Unit : in Ada_Unit) return Boolean is

        Object_Kind : Directory_Tools.Ada_Object.Unit_Kind :=
           Directory_Tools.Ada_Object.Kind (This_Unit);

    begin
        return Ada.Is_Spec (This_Unit) and then
                  (Object_Kind = Directory_Tools.Ada_Object.  
                                    Generic_Package or else
                   Object_Kind = Directory_Tools.Ada_Object.
                                    Generic_Procedure or else
                   Object_Kind = Directory_Tools.Ada_Object.  
                                    Generic_Function);
    end Is_Generic_Spec;

    function Is_Spec_In_Spec_View (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Ada.Is_Spec (This_Unit) and then
                  Any.Is_Contained_By_Spec_View (This_Unit);
    end Is_Spec_In_Spec_View;

    function Is_Spec_In_Load_View (This_Unit : in Ada_Unit) return Boolean is
    begin
        return Ada.Is_Spec (This_Unit) and then
                  Any.Is_Contained_By_Load_View (This_Unit);
    end Is_Spec_In_Load_View;

    function Matching_Spec (Current_Spec : in Ada_Spec;
                            Current_View : in Any.View;
                            Other_View   : in Any.View) return Ada_Spec is
    begin
        declare

            Current_Spec_Name : constant String :=
               Directory_Tools.Naming.Full_Name (Current_Spec);
            Current_View_Name : constant String :=
               Directory_Tools.Naming.Full_Name (Current_View);
            Current_Tail      : constant String :=
               Current_Spec_Name (Current_Spec_Name'First +
                                  Current_View_Name'Length ..
                                     Current_Spec_Name'Last);

            Other_View_Name : constant String :=
               Directory_Tools.Naming.Full_Name (Other_View);
            Other_Spec_Name : constant String := Other_View_Name & Current_Tail;

            Other_Spec : Ada_Spec :=
               Directory_Tools.Naming.Resolution (Other_Spec_Name);

        begin  
            return Other_Spec;
        end;

    exception
        when others =>
            return Utilities.Bad_Object;

    end Matching_Spec;

    function Spec_In_Other_View
                (This_Spec     : in Ada_Spec;
                 This_Activity : in Activity.Activity_Name :=
                    Activity.The_Current_Activity) return Ada_Spec is

        Current_View : Any.View := Any.View_Containing (This_Spec);

    begin  
        if Any.Is_Spec_View (Current_View) then
            return Matching_Spec  
                      (Current_Spec => This_Spec,  
                       Current_View => Current_View,
                       Other_View   =>  
                          Cmvc.Current_Load_View_In
                             (Any.Subsystem_Containing (Current_View),
                              This_Activity));

        elsif Any.Is_Load_View (Current_View) then
            return Matching_Spec  
                      (Current_Spec => This_Spec,  
                       Current_View => Current_View,
                       Other_View   =>  
                          Cmvc.Current_Spec_View_In
                             (Any.Subsystem_Containing (Current_View),
                              This_Activity));

        elsif Any.Is_Combined_View (Current_View) then
            return This_Spec;
        else
            return Utilities.Bad_Object;
        end if;

    exception
        when others =>
            return Utilities.Bad_Object;

    end Spec_In_Other_View;

    function Specs_Withed_By (This_Unit : in Ada_Unit) return Ada_Specs is
    begin
        return Directory_Tools.Ada_Object.List_Of_Withs (This_Unit);
    end Specs_Withed_By;

    function Dependents_Of (This_Unit : in Ada_Unit) return Ada_Units is
    begin
        return Directory_Tools.Ada_Object.Depends_On (This_Unit);
    end Dependents_Of;

    function Parent_Of (This_Unit : in Ada_Unit) return Ada_Unit is
    begin
        if Ada.Is_Spec (This_Unit) then
            return Utilities.Bad_Object;
        elsif Ada.Is_Body (This_Unit) then
            return Directory_Tools.Ada_Object.Other_Part (This_Unit);
        elsif Ada.Is_Subunit (This_Unit) then
            return Directory_Tools.Traversal.Parent (This_Unit);
        end if;

    exception
        when others =>
            return Utilities.Bad_Object;

    end Parent_Of;

    function Subunits_Of (This_Unit : in Ada_Unit) return Subunits is
    begin
        return Directory_Tools.Ada_Object.Subunits
                  (This_Unit, Declared => False);
    end Subunits_Of;

    function Body_For (This_Unit : in Ada_Unit) return Ada_Body is

        Current_Unit : Ada_Unit := This_Unit;

    begin  
        if Ada.Is_Spec (Current_Unit) then
            -- Find body associated with spec.
            Current_Unit :=
               Directory_Tools.Ada_Object.Other_Part (Current_Unit);

        elsif Ada.Is_Subunit (Current_Unit) then
            -- Find parents transitively until get to body.
            while Directory_Tools.Ada_Object.Is_Subunit (Current_Unit) loop
                Current_Unit := Ada.Parent_Of (Current_Unit);
            end loop;
        end if;
        if not Ada.Is_Body (Current_Unit) then
            -- Something went wrong.
            return Utilities.Bad_Object;
        else
            return Current_Unit;
        end if;

    exception
        when others =>
            return Utilities.Bad_Object;

    end Body_For;

    function Spec_For (This_Unit : in Ada_Unit) return Ada_Spec is

        Current_Unit : Ada_Unit := This_Unit;

    begin
        -- Find parents transitively until get to body.
        while Directory_Tools.Ada_Object.Is_Subunit (Current_Unit) loop
            Current_Unit := Ada.Parent_Of (Current_Unit);
        end loop;
        if Ada.Is_Body (Current_Unit) then
            -- Find spec associated with body.
            Current_Unit := Ada.Parent_Of (Current_Unit);
        end if;
        if not Ada.Is_Spec (Current_Unit) then
            -- Something went wrong.
            return Utilities.Bad_Object;
        else
            return Current_Unit;
        end if;

    exception
        when others =>
            return Utilities.Bad_Object;

    end Spec_For;

end Ada;

    nblk1=d
    nid=0
    hdr6=1a
        [0x00] rec0=1b rec1=00 rec2=01 rec3=01c
        [0x01] rec0=17 rec1=00 rec2=02 rec3=094
        [0x02] rec0=19 rec1=00 rec2=03 rec3=086
        [0x03] rec0=00 rec1=00 rec2=0d rec3=00c
        [0x04] rec0=1a rec1=00 rec2=04 rec3=02a
        [0x05] rec0=16 rec1=00 rec2=05 rec3=078
        [0x06] rec0=17 rec1=00 rec2=06 rec3=040
        [0x07] rec0=00 rec1=00 rec2=0c rec3=00a
        [0x08] rec0=1e rec1=00 rec2=07 rec3=024
        [0x09] rec0=1e rec1=00 rec2=08 rec3=00c
        [0x0a] rec0=1e rec1=00 rec2=09 rec3=020
        [0x0b] rec0=1e rec1=00 rec2=0a rec3=006
        [0x0c] rec0=12 rec1=00 rec2=0b rec3=000
    tail 0x217002144815c653ad205 0x42a00088462061e03