|
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: 13020 (0x32dc)
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 Diana_Renames;
with Dirty_Tree;
with Log;
with Profile;
package body Split_Util is
use Diana_Renames;
package Ada renames Directory.Ada;
package Traversal renames Directory.Traversal;
function "=" (X, Y : Directory.Error_Status) return Boolean
renames Directory."=";
procedure Error (Msg : String; Fatal : Boolean := True) is
begin
Log.Put_Line (Msg, Kind => Profile.Negative_Msg);
if Fatal then
raise Failure;
end if;
end Error;
procedure Check (Status : Directory.Error_Status; Msg : String) is
begin
if not Directory."=" (Status, Directory.Successful) then
Error ("error status: " &
Directory.Error_Status'Image (Status) & " while " & Msg);
end if;
end Check;
function Size_Of (Node_List : Diana.Seq_Type) return Integer;
function Size_Of_Block (Block : Diana.Tree) return Integer is
Items : Diana.Seq_Type := Diana.List (Diana.As_Item_S (Block));
Stms : Diana.Seq_Type := Diana.List (Diana.As_Stm_S (Block));
Hdlrs : Diana.Seq_Type := Diana.List (Diana.As_Alternative_S (Block));
begin
return Diana.List_Utilities.Length (Items) +
Size_Of (Stms) + Size_Of (Hdlrs);
end Size_Of_Block;
function Size_Of (Node : Diana.Tree) return Integer is
begin
case Diana.Kind (Node) is
when Diana.Dn_If =>
return Size_Of (Diana.List (Node));
when Diana.Dn_Case =>
return Size_Of (Diana.As_Alternative_S (Node));
when Diana.Dn_Cond_Clause | Diana.Dn_Alternative |
Diana.Dn_Loop | Diana.Dn_Accept | Diana.Dn_Select_Clause =>
return Size_Of (Diana.As_Stm_S (Node));
when Diana.Dn_Block =>
return Size_Of_Block (Node);
when Diana.Dn_Select =>
return Size_Of (Diana.As_Stm_S (Node)) +
Size_Of (Diana.As_Select_Clause_S (Node));
when Diana.Dn_Stm_S | Diana.Dn_Alternative_S |
Diana.Dn_Select_Clause_S =>
return Size_Of (Diana.List (Node));
when others =>
return 0;
end case;
end Size_Of;
function Size_Of (Node_List : Diana.Seq_Type) return Integer is
Nodes : Diana.Seq_Type := Node_List;
Sum : Integer := 0;
begin
while not Diana.Is_Empty (Nodes) loop
Sum := Sum + Size_Of (Diana.Head (Nodes)) + 1;
Nodes := Diana.Tail (Nodes);
end loop;
return Sum;
end Size_Of;
function Compute_Size (Unit_Body : Diana.Tree) return Integer is
begin
return Size_Of_Block (Diana.As_Block_Stub (Unit_Body));
end Compute_Size;
function Is_Overloaded
(Subprogram_Body : Diana.Tree; The_Items : Diana.Seq_Type)
return Boolean is
Items : Diana.Seq_Type := The_Items;
Item : Diana.Tree;
Name : Diana.Symbol_Rep := Diana.Id
(Diana.As_Designator (Subprogram_Body));
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
if "/=" (Item, Subprogram_Body) then
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body =>
if Diana.Equal
(Diana.Id (Diana.As_Designator (Item)), Name) then
return True;
end if;
when others =>
null;
end case;
end if;
Items := Diana.Tail (Items);
end loop;
return False;
end Is_Overloaded;
function Same_Kind
(Def_Id : Diana.Tree; Parent : Diana.Tree) return Boolean is
begin
case Diana.Kind (Parent) is
when Diana.Dn_Function_Call =>
return Diana.Kind (Def_Id) = Diana.Dn_Function_Id;
when Diana.Dn_Procedure_Call =>
return Diana.Kind (Def_Id) = Diana.Dn_Proc_Id;
when others =>
return False;
end case;
end Same_Kind;
procedure Fix_References (Wroot : Diana.Tree;
Stub : Diana.Tree;
Sep_Ids : Diana.Temp_Seq;
Action_Id : Action.Id;
Parent_Name : Diana.Symbol_Rep;
Subunit_Name : Diana.Symbol_Rep;
In_Subunit : Boolean) is
procedure Fix_Refs (Node : Diana.Tree;
Writable_Root : in out Diana.Tree;
Key : in out Ada.Conversion_Key);
procedure Fix_Subunit (Stub_Decl : Diana.Tree) is
Object : Directory.Object;
Status : Directory.Error_Status;
Key : Ada.Conversion_Key;
Root : Ada.Root;
Writable_Root : Diana.Tree;
begin
Traversal.Get_Object (Stub_Decl, Object, Status,
Action_Id => Action_Id);
if Status = Directory.Successful then
Ada.Open (Ada.Get_Unit (Object), Ada.None,
Root, Key, Status, Action_Id);
if Status = Directory.Successful then
Writable_Root := Diana.Empty;
Key := Ada.Nil;
Fix_Refs (Root, Writable_Root, Key);
if not Diana.Is_Empty (Writable_Root) then
Ada.Close (Writable_Root, Status, Action_Id);
Check (Status, "closing subunit opened in fix refs");
end if;
end if;
end if;
end Fix_Subunit;
procedure Open_Space (Name : in out Diana.Tree;
Writable_Root : in out Diana.Tree;
Key : in out Ada.Conversion_Key) is
Root : Diana.Tree;
Unit : Ada.Unit;
The_Key : Ada.Conversion_Key;
Status : Directory.Error_Status;
New_Name : Diana.Tree;
begin
if Diana.Is_Empty (Writable_Root) then
Ada.Get_Unit (Name, Unit, Status);
Check (Status, "getting ada.unit of space in fix_refs");
Ada.Open (Unit, Ada.Update, Writable_Root,
The_Key, Status, Action_Id);
Check (Status, "opening space to fix ref");
Ada.Convert (Name, New_Name, The_Key, Status);
Check (Status, "converting name from old space to new");
Key := The_Key;
Name := New_Name;
elsif not Ada.Is_Nil (Key) then
Ada.Convert (Name, New_Name, Key, Status);
Check (Status, "converting name from old space to new");
Name := New_Name;
end if;
Ada.Set_Diana_Heap (Writable_Root, Status);
Check (Status, "setting diana heap to unit to fix ref");
end Open_Space;
procedure Chk_For_Same_Name (Used_Name : Diana.Tree;
Parent : Diana.Tree;
Writable_Root : in out Diana.Tree;
Key : in out Ada.Conversion_Key) is
Name : Diana.Symbol_Rep := Diana.Id (Used_Name);
Ids : Diana.Temp_Seq := Sep_Ids;
Id : Diana.Tree;
Selected : Diana.Tree;
Uname : Diana.Tree;
Name_Parent : Diana.Tree;
Name1 : Diana.Tree;
begin
while not Diana.Is_Empty (Ids) loop
Id := Diana.Head (Ids);
if Diana.Equal (Diana.Id (Id), Name) and then
Same_Kind (Id, Parent) then
Uname := Used_Name;
Open_Space (Uname, Writable_Root, Key);
Name_Parent := Diana.As_Parent (Uname);
if Diana.Kind (Name_Parent) = Diana.Dn_Selected then
Name1 := Diana.As_Name (Name_Parent);
Diana.Edit_Utilities.Remove (Name1);
Selected :=
Diana.Make (Diana.Dn_Selected,
Dirty_Tree.Copy (Name1),
Diana.Make (Diana.Dn_Used_Name_Id,
Diana.Image (Subunit_Name)));
Diana.As_Name (Name_Parent, Selected);
else
Selected := Diana.Make
(Diana.Dn_Selected,
Diana.Make (Diana.Dn_Used_Name_Id,
Diana.Image (Subunit_Name)),
Dirty_Tree.Copy (Uname));
Diana.Edit_Utilities.Change_Node
(Uname, Selected, False, True);
end if;
return;
end if;
Ids := Diana.Tail (Ids);
end loop;
end Chk_For_Same_Name;
procedure Chk_Nullary_Node (Node : Diana.Tree;
Writable_Root : in out Diana.Tree;
Key : in out Ada.Conversion_Key) is
Parent : Diana.Tree;
Name1 : Diana.Tree;
begin
case Diana.Kind (Node) is
when Diana.Dn_Stub =>
Parent := Diana.As_Parent (Node);
if "/=" (Parent, Stub) then
Fix_Subunit (Parent);
end if;
when Diana.Dn_Used_Name_Id =>
Parent := Diana.As_Parent (Node);
if Diana.Kind (Parent) = Diana.Dn_Selected then
Name1 := Diana.As_Name (Parent);
case Diana.Kind (Name1) is
when Diana.Dn_Selected =>
Name1 := Diana.As_Designator_Char (Name1);
when Diana.Dn_Used_Name_Id =>
null;
when others =>
return;
end case;
if not Diana.Equal (Diana.Id (Name1), Parent_Name) then
return;
end if;
loop
Parent := Diana.As_Parent (Parent);
exit when "/=" (Diana.Kind (Parent),
Diana.Dn_Selected);
end loop;
elsif In_Subunit then
return;
end if;
case Diana.Kind (Parent) is
when Diana.Dn_Procedure_Call | Diana.Dn_Function_Call =>
Chk_For_Same_Name (Node, Parent,
Writable_Root, Key);
when others =>
null;
end case;
when others =>
null;
end case;
end Chk_Nullary_Node;
procedure Fix_Refs (Node : Diana.Tree;
Writable_Root : in out Diana.Tree;
Key : in out Ada.Conversion_Key) is
Nodes : Diana.Seq_Type;
begin
case Diana.Arity (Node) is
when Diana.Nullary =>
Chk_Nullary_Node (Node, Writable_Root, Key);
when Diana.Unary =>
Fix_Refs (Diana.Child1 (Node), Writable_Root, Key);
when Diana.Binary =>
Fix_Refs (Diana.Child1 (Node), Writable_Root, Key);
Fix_Refs (Diana.Child2 (Node), Writable_Root, Key);
when Diana.Ternary =>
Fix_Refs (Diana.Child1 (Node), Writable_Root, Key);
Fix_Refs (Diana.Child2 (Node), Writable_Root, Key);
Fix_Refs (Diana.Child3 (Node), Writable_Root, Key);
when Diana.Arbitrary =>
Nodes := Diana.List (Node);
while not Diana.Is_Empty (Nodes) loop
Fix_Refs (Diana.Head (Nodes), Writable_Root, Key);
Nodes := Diana.Tail (Nodes);
end loop;
end case;
end Fix_Refs;
begin
if Diana.Is_Empty (Sep_Ids) then
return;
end if;
declare
Writable_Root : Diana.Tree := Wroot;
Key : Ada.Conversion_Key := Ada.Nil;
begin
Fix_Refs (Wroot, Writable_Root, Key);
end;
end Fix_References;
end Split_Util;