|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 15360 (0x3c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Hierarchy, seg_010776
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
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;
nblk1=e
nid=0
hdr6=1c
[0x00] rec0=26 rec1=00 rec2=01 rec3=002
[0x01] rec0=1c rec1=00 rec2=02 rec3=024
[0x02] rec0=1f rec1=00 rec2=03 rec3=03c
[0x03] rec0=24 rec1=00 rec2=04 rec3=04e
[0x04] rec0=1c rec1=00 rec2=05 rec3=000
[0x05] rec0=16 rec1=00 rec2=06 rec3=062
[0x06] rec0=14 rec1=00 rec2=07 rec3=054
[0x07] rec0=16 rec1=00 rec2=08 rec3=078
[0x08] rec0=18 rec1=00 rec2=09 rec3=016
[0x09] rec0=1e rec1=00 rec2=0a rec3=016
[0x0a] rec0=1c rec1=00 rec2=0b rec3=026
[0x0b] rec0=22 rec1=00 rec2=0c rec3=038
[0x0c] rec0=26 rec1=00 rec2=0d rec3=016
[0x0d] rec0=01 rec1=00 rec2=0e rec3=000
tail 0x2170c8b6082307710d5e4 0x42a00088462060003