DataMuseum.dk

Presents historical artifacts from the history of:

Rational R1000/400 Tapes

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 Tapes

Excavated with: AutoArchaeologist - Free & Open Source Software.


top - download
Index: ┃ B T

⟦5695163fc⟧ TextFile

    Length: 12467 (0x30b3)
    Types: TextFile
    Names: »B«

Derivation

└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
    └─ ⟦124ff5788⟧ »DATA« 
        └─⟦this⟧ 
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
    └─ ⟦129cab021⟧ »DATA« 
        └─⟦this⟧ 
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
    └─ ⟦6f12a12be⟧ »DATA« 
        └─⟦this⟧ 
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
    └─ ⟦d65440be7⟧ »DATA« 
        └─⟦this⟧ 

TextFile

with Asa_Definitions;
with Asaopen;
with Job_Segment;
with Logger;
with Remote_Operations;
with Simple_Status;
with Time_Utilities;
with Unix_Definitions;
package body Hierarchy is

    package Ro renames Remote_Operations;
    package Ss renames Simple_Status;


    --                    ----------
    --                    ( ) Naming
    --                    ----------


    Hierarchy : constant String :=
       Asa_Definitions.Main_Class_Directory & ".HIERARCHY";

    function Ada_Name (S : in String) return String is
        Offset : constant := Character'Pos ('A') - Character'Pos ('a');
        Result : String (S'Range);
        Next : Natural := S'First;
    begin
        for I in S'Range loop
            case S (I) is

                when 'A' .. 'Z' =>
                    Result (Next) := S (I);
                    Next := Next + 1;

                when 'a' .. 'z' =>
                    Result (Next) := Character'Val
                                        (Character'Pos (S (I)) + Offset);
                    Next := Next + 1;

                when '0' .. '9' =>
                    if Next = S'First then

                        -- An Ada name cannot start with a digit.
                        null;
                    else
                        Result (Next) := S (I);
                        Next := Next + 1;
                    end if;

                when others =>
                    if Next = S'First then

                        -- An Ada name cannot start with an underscore.
                        null;
                    elsif Result (Next - 1) = '_' then

                        -- An Ada name cannot have two consecutive
                        -- underscores.
                        null;

                    else
                        Result (Next) := '_';
                        Next := Next + 1;
                    end if;
            end case;
        end loop;
        if Next > S'First and then Result (Next - 1) = '_' then

            -- An Ada name cannot end with an underscore.
            return Result (S'First .. Next - 2);
        else
            return Result (S'First .. Next - 1);
        end if;
    end Ada_Name;

    --[bug]
    -- Due to a bug in asaopen, the requirements arrive here with
    -- underscores instead of blanks.  They must be converted back.
    --
    function Underlines_To_Spaces (S : in String) return String is
        Result : String (S'Range);
    begin
        for I in S'Range loop
            if S (I) = '_' then
                Result (I) := ' ';
            else
                Result (I) := S (I);
            end if;
        end loop;
        return Result;
    end Underlines_To_Spaces;


    --                    ----------------------------------
    --                    ( ) Bodies of external subprograms
    --                    ----------------------------------


    procedure Build (Model : in String;  
                     Host : in String;
                     Root : out Module;
                     Build_Time : out Calendar.Time) is
        C : Ro.Context;
        S : Simple_Status.Condition;
    begin

        --
        -- Acquire a connection.
        --
        Ro.Acquire (A_Context => C,
                    Status => S,
                    Machine => Host,
                    Instance => Asa_Definitions.Asa);
        Logger.Status (S);

        --
        -- Do the actual build.
        --
        Build (Model => Model,
               In_Context => C,
               Root => Root,
               Build_Time => Build_Time);

        --
        -- Release the connection.
        --
        Ro.Release (A_Context => C, Status => S);
        Logger.Status (S);
    end Build;

    procedure Build (Model : in String;  
                     In_Context : in Remote_Operations.Context;
                     Root : out Module;
                     Build_Time : out Calendar.Time) is

        S : Ss.Condition;

        type Line_Kind is (Identifier,  
                           Node,  
                           Comment,  
                           Requirement_1,  
                           Requirement_2,  
                           Requirement_3,  
                           Requirement_4,  
                           Requirement_5,  
                           Requirement_6,  
                           Requirement_7,  
                           Requirement_8,  
                           Requirement_9,  
                           Children);

        type State_Record is
            record
                Current : Module;  
                Expected : Line_Kind;
            end record;

        My_State : State_Record := (Current => null,  
                                    Expected => Identifier);

        procedure Process (State : in out State_Record; Line : in String) is
            New_Module : Module;
            Nb_Of_Children : Natural;
        begin
            case State.Expected is

                when Identifier =>  
                    if State.Current /= null then

                        New_Module :=
                           new Module_Record'
                                  (Identifier => new String'(Line),
                                   Node_Number => null,
                                   Comment => null,
                                   Requirements => (others => null),
                                   Parent => State.Current,
                                   First_Child => null,
                                   Next_Sibling => State.Current.First_Child,
                                   Remaining_Children => 0);
                        pragma Heap (Job_Segment.Get);

                        State.Current.Remaining_Children :=
                           State.Current.Remaining_Children - 1;
                        State.Current.First_Child := New_Module;
                        State.Current := New_Module;
                    else

                        State.Current :=
                           new Module_Record'(Identifier => new String'(Line),
                                              Node_Number => null,  
                                              Comment => null,
                                              Requirements => (others => null),
                                              Parent => null,
                                              First_Child => null,
                                              Next_Sibling => null,
                                              Remaining_Children => 0);
                        pragma Heap (Job_Segment.Get);

                    end if;

                when Node =>
                    State.Current.Node_Number := new String'(Line);
                    pragma Heap (Job_Segment.Get);

                when Comment =>

                    --
                    -- Asaopen says "(null)" if there is no comment.
                    --
                    if Line = "(null)" then
                        State.Current.Comment := new String'("");
                        pragma Heap (Job_Segment.Get);
                    else
                        State.Current.Comment := new String'(Line);
                        pragma Heap (Job_Segment.Get);
                    end if;

                when Requirement_1 .. Requirement_9 =>  
                    if Line /= "" then
                        State.Current.Requirements
                           (Requirements.Functional_Requirement_Number
                               (Line_Kind'Pos (State.Expected) -
                                Line_Kind'Pos (Line_Kind'Pred
                                                  (Requirement_1)))) :=
                           new String'(Underlines_To_Spaces (Line));
                        pragma Heap (Job_Segment.Get);
                    end if;

                when Children =>
                    Nb_Of_Children := Natural'Value (Line);
                    case Nb_Of_Children is

                        when 0 =>
                            while State.Current.Remaining_Children = 0 and then
                                     State.Current.Parent /= null loop
                                State.Current := State.Current.Parent;
                            end loop;

                        when Positive =>
                            State.Current.Remaining_Children := Nb_Of_Children;
                    end case;
            end case;

            if State.Expected = Line_Kind'Last then
                State.Expected := Line_Kind'First;
            else
                State.Expected := Line_Kind'Succ (State.Expected);
            end if;
        end Process;

        procedure Execute_Script is
           new Asaopen.Execute (State_Record => State_Record,
                                Process => Process);

    begin

        --
        -- Get the remote model's update time.
        --
        Ro.Update_Time (Of_File => Model,  
                        In_Context => In_Context,
                        Result => Build_Time,
                        Status => S);
        if Ss.Error (S) then
            Logger.Error ("Unable to open remote model " & Model,
                          Raise_Error => False);
            Logger.Status (S);
        end if;

        --
        -- Execute the script to extract the hierarchy information.
        --
        Execute_Script (In_Context => In_Context,
                        Model => Model,
                        Template_Name => Hierarchy,
                        State => My_State,
                        Status => S);
        Logger.Status (S);

        Root := My_State.Current;  
    end Build;

    function Make (Identifier : in String) return Module is
    begin
        return new Module_Record'(Identifier => new String'(Identifier),
                                  Node_Number => new String'("M"),
                                  Comment => new String'(""),
                                  Requirements => (others => null),
                                  Parent => null,
                                  First_Child => null,
                                  Next_Sibling => null,
                                  Remaining_Children => 0);
        pragma Heap (Job_Segment.Get);
    end Make;

    function Children_Of (M : in Module) return Module_Iterator is
    begin
        return Module_Iterator (M.First_Child);
    end Children_Of;

    function Parent_Of (M : in Module) return Module is
    begin
        return M.Parent;
    end Parent_Of;

    function Identifier (M : in Module) return String is
    begin
        return M.Identifier.all;
    end Identifier;

    function Simple_Name (M : in Module) return String is
    begin
        return Ada_Name (M.Identifier.all);
    end Simple_Name;

    function Full_Name (M : in Module) return String is
    begin
        if M.Parent = null then
            return Ada_Name (M.Identifier.all);
        else
            return Full_Name (M.Parent) & '.' & Ada_Name (M.Identifier.all);
        end if;
    end Full_Name;

    function Node_Number (M : in Module) return String is
    begin
        return M.Node_Number.all;
    end Node_Number;

    function Comment (M : in Module) return String is
    begin
        return M.Comment.all;
    end Comment;

    function Requirement
                (M : in Module;  
                 Number : in Requirements.Functional_Requirement_Number)
                return String is
    begin  
        if M.Requirements (Number) = null then
            return "";
        else
            return M.Requirements (Number).all;
        end if;
    end Requirement;

    function Done (M : in Module_Iterator) return Boolean is
    begin
        return M = null;
    end Done;

    function Value (M : in Module_Iterator) return Module is
    begin
        return Module (M);
    end Value;

    procedure Next (M : in out Module_Iterator) is
    begin
        M := Module_Iterator (M.Next_Sibling);
    end Next;

    function Size (M : in Module_Iterator) return Natural is
        Iter : Module_Iterator := M;  
        Result : Natural := 0;
    begin
        while Iter /= null loop
            Result := Result + 1;
            Iter := Module_Iterator (Iter.Next_Sibling);
        end loop;
        return Result;
    end Size;

    function Make (M : in Module) return Module_Iterator is
    begin
        return Module_Iterator (M);
    end Make;

end Hierarchy;