|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 11735 (0x2dd7)
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⟧
with Directory_Tools;
with Object_Set;
with Diana;
with Set_Generic;
with Action;
with Ada_Object_Editor;
with Io;
package body Context_Tools is
Done : exception;
package Simple_Text_Io renames Io;
package Root_Set is new Set_Generic (Diana.Tree);
function "=" (K1, K2 : Diana.Node_Name) return Boolean renames Diana."=";
function "=" (E1, E2 : Dir.Error_Status) return Boolean renames Dir."=";
Context_Roots_Not_Referenced : Root_Set.Set;
Context_Roots_Used : Root_Set.Set;
Context_Body_Only : Root_Set.Set;
Context_Subunits_Only : Root_Set.Set;
procedure Check_Used (Tree : Diana.Tree) is
The_Root : Diana.Tree;
Status : Dir.Error_Status;
Ids : Diana.Seq_Type := Diana.As_List (Tree);
begin
while not Diana.Is_Empty (Ids) loop
declare
Node : Diana.Tree := Diana.Head (Ids);
begin
case Diana.Kind (Node) is
when Diana.Dn_Used_Name_Id =>
null;
when Diana.Dn_Selected =>
while Diana."=" (Diana.Kind (Node),
Diana.Dn_Selected) loop
Node := Diana.As_Name (Node);
end loop;
when others =>
raise Program_Error;
end case;
Dir.Ada.Get_Root (Diana.Sm_Defn (Node), The_Root, Status);
exception
when others =>
Simple_Text_Io.Put_Line
("%%% exception raised on node kind " &
Diana.Node_Name'Image (Diana.Kind (Node)));
Ada_Object_Editor.Display (Node);
raise;
end;
Root_Set.Add (Context_Roots_Used, The_Root);
Ids := Diana.Tail (Ids);
end loop;
end Check_Used;
procedure Check_Used_Name (Tree : Diana.Tree) is
The_Root : Diana.Tree;
Status : Dir.Error_Status;
begin
Dir.Ada.Get_Root (Diana.Sm_Defn (Tree), The_Root, Status);
Root_Set.Delete (Context_Roots_Not_Referenced, The_Root);
if Root_Set.Is_Empty (Context_Roots_Not_Referenced) then
raise Done;
end if;
end Check_Used_Name;
procedure Check_Object_Id (Tree : Diana.Tree) is
The_Root : Diana.Tree;
Status : Dir.Error_Status;
begin
Dir.Ada.Get_Root (Diana.Sm_Defn (Tree), The_Root, Status);
Root_Set.Delete (Context_Roots_Not_Referenced, The_Root);
if Root_Set.Is_Empty (Context_Roots_Not_Referenced) then
raise Done;
end if;
end Check_Object_Id;
procedure Walk (Tree : Diana.Tree) is
Node_Arity : Diana.Arities;
This_Seq : Diana.Seq_Type;
begin
case Diana.Kind (Tree) is
when Diana.Dn_Use =>
Check_Used (Tree);
return;
when Diana.Dn_Used_Name_Id =>
Check_Used_Name (Tree);
return;
when Diana.Dn_Used_Object_Id =>
Check_Object_Id (Tree);
return;
when others =>
null;
end case;
Node_Arity := Diana.Arity (Tree);
case Node_Arity is
when Diana.Nullary =>
null;
when Diana.Unary =>
Walk (Diana.Child1 (Tree));
when Diana.Binary =>
Walk (Diana.Child1 (Tree));
Walk (Diana.Child2 (Tree));
when Diana.Ternary =>
Walk (Diana.Child1 (Tree));
Walk (Diana.Child2 (Tree));
Walk (Diana.Child3 (Tree));
when Diana.Arbitrary =>
This_Seq := Diana.As_List (Tree);
while not Diana.Is_Empty (This_Seq) loop
Walk (Diana.Head (This_Seq));
This_Seq := Diana.Tail (This_Seq);
end loop;
end case;
end Walk;
procedure Traverse_Context_Use_Clauses (Comp_Unit : Diana.Tree) is
Context_Elements : Diana.Seq_Type :=
Diana.As_List (Diana.As_Context (Comp_Unit));
begin
while not Diana.Is_Empty (Context_Elements) loop
case Diana.Kind (Diana.Head (Context_Elements)) is
when Diana.Dn_Use =>
Walk (Diana.Head (Context_Elements));
when others =>
null;
end case;
Context_Elements := Diana.Tail (Context_Elements);
end loop;
end Traverse_Context_Use_Clauses;
procedure Traverse_All (Object : Dir.Object) is
Body_Unit : Dir.Ada.Unit;
Subunits_Iter : Dir.Traversal.Subunit_Iterator;
Status : Dir.Error_Status;
Temp_Subunits_Only : Root_Set.Set;
Root : Diana.Tree;
begin
if Dir.Traversal.Is_Visible_Part (Dir.Ada.Get_Unit (Object)) then
begin
Root := Directory_Tools.Get_Root (Object);
exception
when Directory_Tools.Failure =>
return;
when Directory_Tools.Illegal_Operation =>
return;
end;
begin
Walk (Diana.As_Unit_Body (Root));
Traverse_Context_Use_Clauses (Root);
Dir.Traversal.Get_Other_Part
(Dir.Ada.Get_Unit (Object), Body_Unit, Status);
if "/=" (Status, Dir.Successful) then
return;
end if;
begin
Root := Directory_Tools.Get_Root
(Dir.Ada.Get_Object (Body_Unit));
exception
when Directory_Tools.Failure |
Directory_Tools.Illegal_Operation =>
return;
end;
Root_Set.Copy (Target => Context_Body_Only,
Source => Context_Roots_Not_Referenced);
Walk (Diana.As_Unit_Body (Root));
Root_Set.Copy (Target => Temp_Subunits_Only,
Source => Context_Roots_Not_Referenced);
exception
when Done =>
return;
end;
else
Body_Unit := Dir.Ada.Get_Unit (Object);
begin
Root := Directory_Tools.Get_Root
(Dir.Ada.Get_Object (Body_Unit));
exception
when Directory_Tools.Failure |
Directory_Tools.Illegal_Operation =>
return;
end;
begin
Walk (Diana.As_Unit_Body (Root));
Traverse_Context_Use_Clauses (Root);
Root_Set.Copy (Target => Temp_Subunits_Only,
Source => Context_Roots_Not_Referenced);
exception
when Done =>
return;
end;
end if;
Dir.Traversal.Init (Body_Unit, Action.Null_Id, Subunits_Iter, Status);
while not Dir.Traversal.Done (Subunits_Iter) loop
Traverse_All (Dir.Ada.Get_Object
(Dir.Traversal.Value (Subunits_Iter)));
Dir.Traversal.Next (Subunits_Iter);
end loop;
Root_Set.Copy (Context_Subunits_Only, Temp_Subunits_Only);
end Traverse_All;
procedure Filter_Context_Clauses
(Object : Dir.Object;
Contexts_Not_Required : in out Object_Set.Set;
Use_Clause_Only : in out Object_Set.Set;
Used_In_Body_Only : in out Object_Set.Set;
Used_In_Subunits_Only : in out Object_Set.Set) is
Context_Set : Object_Set.Set :=
Directory_Tools.Objects_In_Context_Clause (Object);
Context_Iterator : Object_Set.Iterator;
Root_Iterator : Root_Set.Iterator;
begin
Object_Set.Make_Empty (Contexts_Not_Required);
Object_Set.Make_Empty (Use_Clause_Only);
Object_Set.Make_Empty (Used_In_Body_Only);
Object_Set.Make_Empty (Used_In_Subunits_Only);
if Object_Set.Is_Empty (Context_Set) then
return;
end if;
Root_Set.Make_Empty (Context_Roots_Used);
Root_Set.Make_Empty (Context_Roots_Not_Referenced);
Root_Set.Make_Empty (Context_Body_Only);
Root_Set.Make_Empty (Context_Subunits_Only);
Object_Set.Init (Context_Iterator, Context_Set);
while not Object_Set.Done (Context_Iterator) loop
Root_Set.Add (Context_Roots_Not_Referenced,
Directory_Tools.Get_Root
(Object_Set.Value (Context_Iterator)));
Object_Set.Next (Context_Iterator);
end loop;
Traverse_All (Object);
Root_Set.Init (Root_Iterator, Context_Roots_Not_Referenced);
while not Root_Set.Done (Root_Iterator) loop
Object_Set.Add (Contexts_Not_Required,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Root_Set.Next (Root_Iterator);
end loop;
Root_Set.Init (Root_Iterator, Context_Roots_Used);
while not Root_Set.Done (Root_Iterator) loop
if Root_Set.Is_Member (Context_Roots_Not_Referenced,
Root_Set.Value (Root_Iterator)) then
Object_Set.Delete (Contexts_Not_Required,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Object_Set.Add (Use_Clause_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
end if;
Root_Set.Next (Root_Iterator);
end loop;
Root_Set.Init (Root_Iterator, Context_Body_Only);
while not Root_Set.Done (Root_Iterator) loop
Object_Set.Add (Used_In_Body_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Root_Set.Next (Root_Iterator);
end loop;
Root_Set.Init (Root_Iterator, Context_Subunits_Only);
while not Root_Set.Done (Root_Iterator) loop
Object_Set.Add (Used_In_Subunits_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Root_Set.Next (Root_Iterator);
end loop;
Root_Set.Init (Root_Iterator, Context_Roots_Not_Referenced);
while not Root_Set.Done (Root_Iterator) loop
Object_Set.Delete (Used_In_Body_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Object_Set.Delete (Used_In_Subunits_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Root_Set.Next (Root_Iterator);
end loop;
Root_Set.Init (Root_Iterator, Context_Subunits_Only);
while not Root_Set.Done (Root_Iterator) loop
Object_Set.Delete (Used_In_Body_Only,
Directory_Tools.Get_Object_Of_Any_Node
(Root_Set.Value (Root_Iterator)));
Root_Set.Next (Root_Iterator);
end loop;
end Filter_Context_Clauses;
end Context_Tools;