|
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: 34015 (0x84df)
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 Action;
with Diana;
with Diana_Renames;
with Error_Messages;
with Directory;
with Profile;
with Log;
with Io;
with Io_Exceptions;
with String_Utilities;
with Dirty_Tree;
with Split_Util;
package body Split is
use Diana_Renames;
package Naming renames Directory.Naming;
package Decl_Ops renames Directory.Declaration_Operations;
package Ada renames Directory.Ada;
package Traversal renames Directory.Traversal;
function "=" (X, Y : Directory.Error_Status) return Boolean
renames Directory."=";
function "=" (X, Y : Naming.Name_Status) return Boolean renames Naming."=";
Failure : exception renames Split_Util.Failure;
type Unit_Kind is (Subprogram_Body, Task_Body, Package_Body);
type Unit_Kinds is array (Unit_Kind) of Boolean;
procedure Error (Msg : String; Fatal : Boolean := True)
renames Split_Util.Error;
procedure Check (Status : Directory.Error_Status; Msg : String)
renames Split_Util.Check;
generic
with procedure Process_Unit (Root : Ada.Root;
Unit : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id);
procedure Process_Unit_List (Root : Ada.Root;
Units : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id);
function Is_Separable
(Item : Diana.Tree; Items : Diana.Seq_Type; Kinds : Unit_Kinds)
return Boolean is
begin
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body =>
return Kinds (Subprogram_Body) and then
Diana.Kind (Diana.As_Block_Stub (Item)) =
Diana.Dn_Block and then
not Split_Util.Is_Overloaded (Item, Items);
when Diana.Dn_Package_Body =>
return Kinds (Package_Body) and then
Diana.Kind (Diana.As_Block_Stub (Item)) =
Diana.Dn_Block;
when Diana.Dn_Task_Body =>
return Kinds (Task_Body) and then
Diana.Kind (Diana.As_Block_Stub (Item)) =
Diana.Dn_Block;
when others =>
return False;
end case;
end Is_Separable;
function Get_Items (Root : Diana.Tree) return Diana.Tree is
Node : Diana.Tree;
Block : Diana.Tree;
begin
if "/=" (Diana.Kind (Root), Diana.Dn_Comp_Unit) then
Node := Root;
else
Node := Diana.As_Unit_Body (Root);
end if;
if Diana.Kind (Node) = Diana.Dn_Subunit then
Node := Diana.As_Subunit_Body (Node);
end if;
case Diana.Kind (Node) is
when Diana.Dn_Package_Body | Diana.Dn_Task_Body |
Diana.Dn_Subprogram_Body =>
Block := Diana.As_Block_Stub (Node);
if "/=" (Diana.Kind (Block), Diana.Dn_Block) then
Error ("Unit has no block");
end if;
return Diana.As_Item_S (Block);
when others =>
Error ("Unit is not a package, task, or subprogram body");
end case;
end Get_Items;
procedure Copy_Unit (Def_Id : Diana.Tree;
Block : Diana.Tree;
Item : Diana.Tree;
New_Root : out Diana.Tree) is
Subunit : Diana.Tree;
New_Id : Diana.Tree := Dirty_Tree.Copy (Def_Id);
Kind : Diana.Node_Name := Diana.Kind (Item);
begin
case Kind is
when Diana.Dn_Subprogram_Body =>
Subunit := Diana.Make (Diana.Dn_Subprogram_Body, New_Id,
Dirty_Tree.Copy (Diana.As_Header (Item)),
Dirty_Tree.Copy (Block));
when Diana.Dn_Task_Body | Diana.Dn_Package_Body =>
Subunit := Diana.Make (Kind, New_Id, Dirty_Tree.Copy (Block));
when others =>
null;
end case;
New_Root := Subunit;
end Copy_Unit;
procedure Separate_Body (Unit_Body : Diana.Tree;
Threshhold : Stmt_Decl_Count;
Action_Id : Action.Id) is
Copy : Diana.Tree;
Status : Directory.Error_Status;
Block : Diana.Tree;
Def_Id : Diana.Tree := Diana.Id_Utilities.Get_Id (Unit_Body);
Object : Directory.Object;
New_Root : Ada.Root;
Key : Ada.Conversion_Key;
Subunit : Diana.Tree;
begin
if Threshhold >= Split_Util.Compute_Size (Unit_Body) then
return;
end if;
Log.Put_Line ("Separating " & Diana.Image (Diana.Id (Def_Id)));
Ada.Set_Diana_Heap (Unit_Body, Status);
Check (Status, "setting diana heap to unit");
Block := Diana.As_Block_Stub (Unit_Body);
Diana.As_Block_Stub (Unit_Body, Diana.Make (Diana.Dn_Stub));
Traversal.Get_Object (Def_Id, Object, Status, Action_Id => Action_Id);
Check (Status, "getting object for new stub");
Ada.Open (Ada.Get_Unit (Object), Ada.Update,
New_Root, Key, Status, Action_Id);
Check (Status, "opening space for subunit");
Ada.Set_Diana_Heap (New_Root, Status);
Check (Status, "setting diana heap to new subunit");
Copy_Unit (Def_Id, Block, Unit_Body, Subunit);
Ada.Set_Root (Subunit, Status, Action_Id);
Check (Status, "setting root of new subunit");
Ada.Close (Subunit, Status, Action_Id);
Check (Status, "closing new subunit");
end Separate_Body;
procedure Separate_Bodies (Root : Ada.Root;
Threshhold : Stmt_Decl_Count;
Kinds : Unit_Kinds;
Action_Id : Action.Id) is
Item : Diana.Tree;
Items : Diana.Seq_Type := Diana.List (Get_Items (Root));
The_Items : Diana.Seq_Type := Items;
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
if Is_Separable (Item, The_Items, Kinds) then
Separate_Body (Item, Threshhold, Action_Id);
end if;
Items := Diana.Tail (Items);
end loop;
end Separate_Bodies;
procedure Process_Unit_To_Separate (Root : Ada.Root;
Unit : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id) is
Items : Diana.Seq_Type := Diana.List (Get_Items (Root));
The_Items : Diana.Seq_Type := Items;
Item : Diana.Tree;
begin
if Unit = "" then
return;
end if;
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body |
Diana.Dn_Package_Body | Diana.Dn_Task_Body =>
if Diana.Image (Diana.Id
(Diana.Id_Utilities.Get_Id (Item))) =
String_Utilities.Upper_Case (Unit) and then
Is_Separable (Item, The_Items, Kinds) then
Separate_Body (Item, 0, Action_Id);
return;
end if;
when others =>
null;
end case;
Items := Diana.Tail (Items);
end loop;
Error ("Can't find unit " & Unit, False);
end Process_Unit_To_Separate;
procedure Process_Unit_List (Root : Ada.Root;
Units : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id) is
procedure Scan_Name_String (Units : String) is
Next : Integer := Units'First;
Start : Integer;
begin
loop
while Next <= Units'Last and then Units (Next) = ' ' loop
Next := Next + 1;
end loop;
exit when Next > Units'Last;
Start := Next;
while Next <= Units'Last and then Units (Next) /= ' ' loop
Next := Next + 1;
end loop;
Process_Unit (Root, Units (Start .. Next - 1),
Kinds, Action_Id);
end loop;
end Scan_Name_String;
procedure Read_Names_From_File (Units : String) is
Infile : Io.File_Type;
begin
begin
Io.Open (Infile, Io.In_File, Units);
exception
when others =>
Error ("Error opening " & Units, False);
return;
end;
loop
Process_Unit
(Root, String_Utilities.Strip (Io.Get_Line (Infile)),
Kinds, Action_Id);
end loop;
Io.Close (Infile);
exception
when Io_Exceptions.End_Error =>
Io.Close (Infile);
when others =>
Io.Close (Infile);
raise;
end Read_Names_From_File;
begin
case Units (Units'First) is
when '\' =>
Read_Names_From_File (Units (Units'First + 1 .. Units'Last));
when '!' | '$' | '^' =>
Read_Names_From_File (Units);
when others =>
Scan_Name_String (Units);
end case;
end Process_Unit_List;
procedure Demote_Unit (Def_Id : Directory.Declaration;
Root : out Ada.Root;
Action_Id : Action.Id) is
Errors : Error_Messages.Errors;
Impact : Ada.Roots;
Status : Directory.Error_Status;
Result : Diana.Tree;
Object : Directory.Object;
The_Root : Ada.Root;
Key : Ada.Conversion_Key;
Modified : Diana.Temp_Seq;
begin
Traversal.Get_Object (Def_Id, Object, Status);
Check (Status, "getting object for " &
Naming.Unique_Full_Name (Def_Id));
Ada.Open (Ada.Get_Unit (Object), Ada.None,
The_Root, Key, Status, Action.Null_Id);
Check (Status, "getting root for " & Naming.Unique_Full_Name (Def_Id));
Decl_Ops.Demote (Location => The_Root,
Errors => Errors,
Result => Result,
Modified_Units => Modified,
Change_Impact => Impact,
Status => Status,
-- action_id => action_id,
Goal_State => Decl_Ops.Source);
Check (Status, "demoting " & Naming.Unique_Full_Name (Def_Id));
Root := Result;
end Demote_Unit;
procedure Find_Unit (Unit_To_Split : Ada_Unit_Name;
Def_Id : out Directory.Declaration) is
N_Status : Naming.Name_Status;
begin
Naming.Resolve (Unit_To_Split & "'body'c(ada)",
Naming.Default_Context, Def_Id, N_Status);
if "/=" (N_Status, Naming.Successful) then
Log.Put_Line ("Can't resolve " & Unit_To_Split & "'body");
raise Failure;
end if;
end Find_Unit;
procedure Make_Writable (Root : Diana.Tree;
Result : out Diana.Tree;
Action_Id : Action.Id) is
Status : Directory.Error_Status;
Version : Directory.Version;
Key : Ada.Conversion_Key;
begin
Ada.Get_Version (Root, Version, Status);
Check (Status, "getting version of root");
Ada.Open (Version, Ada.Update, Result, Key, Status, Action_Id);
Check (Status, "opening unit for update");
end Make_Writable;
procedure Process_Unit_List_To_Separate is
new Process_Unit_List (Process_Unit_To_Separate);
procedure Separate_Subunits (Unit_To_Split : Ada_Unit_Name;
Unit_Sizes_To_Separate : Stmt_Decl_Count := 20;
Subunits_To_Separate : String := "";
Separate_Subprograms : Boolean := True;
Separate_Tasks : Boolean := True;
Separate_Packages : Boolean := True) is
Def_Id : Directory.Declaration;
Root : Ada.Root;
Wroot : Ada.Root;
Kinds : Unit_Kinds := (Separate_Subprograms,
Separate_Tasks, Separate_Packages);
Status : Directory.Error_Status;
Old_Heap : Ada.Root;
Action_Id : Action.Id := Action.Start;
begin
Log.Put_Line ("[Split.Separate_Subunits, """ & Unit_To_Split &
"""," & Integer'Image (Unit_Sizes_To_Separate) &
", """ & Subunits_To_Separate & """, " &
Boolean'Image (Separate_Subprograms) & ", " &
Boolean'Image (Separate_Tasks) & ", " &
Boolean'Image (Separate_Packages) & "]");
Find_Unit (Unit_To_Split, Def_Id);
Demote_Unit (Def_Id, Root, Action_Id);
Make_Writable (Root, Wroot, Action_Id);
Ada.Get_Diana_Heap (Old_Heap, Status);
Check (Status, "getting old diana heap");
if Subunits_To_Separate /= "" then
Process_Unit_List_To_Separate
(Wroot, Subunits_To_Separate, Kinds, Action_Id);
else
Separate_Bodies (Wroot, Unit_Sizes_To_Separate, Kinds, Action_Id);
end if;
Ada.Set_Diana_Heap (Old_Heap, Status);
Ada.Close (Wroot, Status, Action_Id);
Check (Status, "closing unit");
Action.Finish (Action_Id, Do_Commit => True);
Log.Put_Line ("[End of Split.Separate_Subunits]");
exception
when Failure =>
Action.Finish (Action_Id, Do_Commit => False);
Ada.Set_Diana_Heap (Old_Heap, Status);
Log.Put_Line ("[End of Split.Separate_Subunits]");
when others =>
Action.Finish (Action_Id, Do_Commit => False);
Error ("Unexpected exception", False);
Ada.Set_Diana_Heap (Old_Heap, Status);
Log.Put_Line ("[End of Split.Separate_Subunits]");
end Separate_Subunits;
function No_Forward
(Body_Id : Diana.Tree;
Item_S : Diana.Seq_Type;
Stop_Decl : Diana.Tree := Diana.Empty) return Boolean is
Name : Diana.Symbol_Rep := Diana.Id (Body_Id);
Items : Diana.Seq_Type := Item_S;
Item : Diana.Tree;
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
exit when Item = Stop_Decl;
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Decl | Diana.Dn_Generic =>
if Diana.Equal (Diana.Id (Diana.Id_Utilities.Get_Id (Item)),
Name) then
return False;
end if;
when others =>
null;
end case;
Items := Diana.Tail (Items);
end loop;
return True;
end No_Forward;
procedure Get_Decls (Pkg_Body_Id : Diana.Tree;
Decls1 : out Diana.Tree;
Decls2 : out Diana.Tree) is
Status : Directory.Error_Status;
Nstatus : Naming.Name_Status;
Unit : Ada.Unit;
Vis_Id : Diana.Tree;
Spec : Diana.Tree;
Object : Directory.Object;
Vroot : Diana.Tree;
Key : Ada.Conversion_Key;
begin
Ada.Get_Unit (Pkg_Body_Id, Unit, Status);
Check (Status, " getiing ada.unit for root unit");
declare
Name : constant String :=
Naming.Get_Prefix (Naming.Unique_Full_Name
(Ada.Get_Object (Unit)));
begin
Naming.Resolve (Name & "." &
Diana.Image (Diana.Id (Pkg_Body_Id)) & "'spec",
Naming.Default_Context, Vis_Id, Nstatus);
if Nstatus = Naming.Successful and then
Diana.Kind (Vis_Id) = Diana.Dn_Package_Id then
Spec := Diana.As_Package_Def (Diana.As_Parent (Vis_Id));
if Diana.Kind (Spec) = Diana.Dn_Stub then
Traversal.Get_Object (Vis_Id, Object, Status);
Ada.Open (Ada.Get_Unit (Object), Ada.None,
Vroot, Key, Status, Action.Null_Id);
Vis_Id := Diana.Id_Utilities.Get_Id (Vroot);
Spec := Diana.As_Package_Def (Diana.As_Parent (Vis_Id));
end if;
if Diana.Kind (Spec) = Diana.Dn_Package_Spec then
Decls1 := Diana.As_Decl_S1 (Spec);
Decls2 := Diana.As_Decl_S2 (Spec);
return;
end if;
end if;
end;
Decls1 := Diana.Empty;
Decls2 := Diana.Empty;
exception
when others =>
Decls1 := Diana.Empty;
Decls2 := Diana.Empty;
end Get_Decls;
function One_Part (Root : Diana.Tree;
Subp_Body : Diana.Tree;
Subp_Body_Id : Diana.Tree) return Boolean is
First_Id : Diana.Tree := Diana.Sm_First (Subp_Body_Id);
Root_Id : Diana.Tree;
Items : Diana.Seq_Type;
Decls1 : Diana.Tree;
Decls2 : Diana.Tree;
begin
if not Diana.Is_Empty (First_Id) then
return First_Id = Subp_Body_Id;
end if;
Items := Diana.List (Get_Items (Root));
Root_Id := Diana.Id_Utilities.Get_Id (Root);
case Diana.Kind (Root_Id) is
when Diana.Dn_Package_Id =>
if No_Forward (Subp_Body_Id, Items, Subp_Body) then
Get_Decls (Root_Id, Decls1, Decls2);
return not Diana.Is_Empty (Decls1) and then
No_Forward (Subp_Body_Id,
Diana.List (Decls1)) and then
No_Forward (Subp_Body_Id, Diana.List (Decls2));
else
return False;
end if;
when Diana.Dn_Task_Body_Id | Diana.Dn_Proc_Id |
Diana.Dn_Function_Id =>
return No_Forward (Subp_Body_Id, Items, Subp_Body);
when others =>
return False;
end case;
exception
when others =>
return False;
end One_Part;
procedure Separate_Body_Into_Subunit (Root : Diana.Tree;
Subp_Body : Diana.Tree;
Vpart : Diana.Tree;
Sroot : Ada.Root;
Threshhold : Stmt_Decl_Count;
Sep_Ids : in out Diana.Temp_Seq;
Separated : out Boolean) is
Subp_Id : Diana.Tree := Diana.As_Designator (Subp_Body);
New_Body : Diana.Tree;
Items : Diana.Tree;
Status : Directory.Error_Status;
Spec : Diana.Tree;
Decls : Diana.Tree;
begin
if "/=" (Diana.Kind (Diana.As_Block_Stub (Subp_Body)),
Diana.Dn_Block) or else
Diana.Kind (Subp_Id) = Diana.Dn_Def_Op or else
Threshhold >= Split_Util.Compute_Size (Subp_Body) or else
not One_Part (Root, Subp_Body, Subp_Id) then
Separated := False;
return;
end if;
Log.Put_Line ("Moving " & Diana.Image (Diana.Id (Subp_Id)) &
" to subunit " &
Diana.Image (Diana.Id (Diana.As_Id (Vpart))));
Ada.Set_Diana_Heap (Subp_Body, Status);
Check (Status, "setting diana heap to unit");
Diana.Edit_Utilities.Remove (Subp_Body);
Spec := Diana.Make
(Diana.Dn_Subprogram_Decl, Dirty_Tree.Copy (Subp_Id),
Dirty_Tree.Copy (Diana.As_Header (Subp_Body)), Diana.Empty);
Decls := Diana.As_Decl_S1 (Diana.As_Package_Def (Vpart));
Diana.List_Utilities.Insert
(Decls, Spec, Diana.List_Utilities.Length (Diana.List (Decls)));
Ada.Set_Diana_Heap (Sroot, Status);
Check (Status, "setting diana heap to subunit");
New_Body := Dirty_Tree.Copy (Subp_Body);
Items := Get_Items (Sroot);
Diana.List_Utilities.Insert
(Items, New_Body, Diana.List_Utilities.Length (Diana.List (Items)));
Sep_Ids := Diana.Cons (Subp_Id, Sep_Ids);
Separated := True;
end Separate_Body_Into_Subunit;
procedure Separate_Bodies_Into_Subunit (Root : Ada.Root;
Vpart : Diana.Tree;
Sroot : Ada.Root;
Threshhold : Stmt_Decl_Count;
Kinds : Unit_Kinds;
Action_Id : Action.Id;
Sep_Ids : in out Diana.Temp_Seq) is
Item : Diana.Tree;
Items : Diana.Seq_Type := Diana.List (Get_Items (Root));
The_Items : Diana.Seq_Type := Items;
Separated : Boolean;
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
Items := Diana.Tail (Items);
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body =>
Separate_Body_Into_Subunit (Root, Item, Vpart, Sroot,
Threshhold, Sep_Ids, Separated);
when others =>
null;
end case;
end loop;
end Separate_Bodies_Into_Subunit;
procedure Process_Unit_List_Subunitize (Root : Ada.Root;
Vpart : Diana.Tree;
Sroot : Ada.Root;
Units : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id;
Sep_Ids : in out Diana.Temp_Seq) is
procedure Process_Unit (Root : Ada.Root;
Unit : String;
Kinds : Unit_Kinds;
Action_Id : Action.Id) is
Items : Diana.Seq_Type := Diana.List (Get_Items (Root));
The_Items : Diana.Seq_Type := Items;
Item : Diana.Tree;
Separated : Boolean;
begin
if Unit = "" then
return;
end if;
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
Items := Diana.Tail (Items);
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body =>
if Diana.Image (Diana.Id (Diana.As_Designator (Item))) =
String_Utilities.Upper_Case (Unit) then
Separate_Body_Into_Subunit
(Root, Item, Vpart, Sroot,
0, Sep_Ids, Separated);
if not Separated then
Error ("Can't separate " & Unit, False);
end if;
return;
end if;
when others =>
null;
end case;
end loop;
Error ("Can't find unit " & Unit, False);
end Process_Unit;
procedure Process_Units is new Process_Unit_List (Process_Unit);
begin
Process_Units (Root, Units, Kinds, Action_Id);
end Process_Unit_List_Subunitize;
procedure Insert_Visible_Part (Vpart : Diana.Tree; Item_S : Diana.Tree) is
Item : Diana.Tree;
Items : Diana.Seq_Type := Diana.List (Item_S);
The_Items : Diana.Seq_Type := Items;
Pos : Integer := 0;
-- use_clause : diana.tree;
begin
-- use_clause :=
-- diana.make
-- (diana.dn_use,
-- diana.list_utilities.list
-- (diana.make (diana.dn_used_name_id,
-- diana.image (diana.id (diana.as_id (vpart))))));
if Diana.Is_Empty (Items) then
Diana.As_List (Item_S, Diana.List_Utilities.List (Vpart));
else
loop
Item := Diana.Head (Items);
case Diana.Kind (Item) is
when Diana.Dn_Subprogram_Body |
Diana.Dn_Package_Body | Diana.Dn_Task_Body =>
Diana.List_Utilities.Insert (Item_S, Vpart, Pos);
-- diana.list_utilities.insert
-- (item_s, use_clause, pos + 1);
return;
when others =>
Items := Diana.Tail (Items);
exit when Diana.Is_Empty (Items);
Pos := Pos + 1;
end case;
end loop;
Diana.List_Utilities.Nconc (The_Items, Vpart);
-- diana.list_utilities.nconc (the_items, use_clause);
end if;
end Insert_Visible_Part;
function Get_Subunit_Name
(Subunit_Name : String; Unit_Id : Diana.Tree) return String is
begin
if Subunit_Name /= "" then
return Subunit_Name;
else
return Diana.Image (Diana.Id (Unit_Id)) & "_UTIL";
end if;
end Get_Subunit_Name;
function Make_Subunit_Name (Subunit_Name : String) return Diana.Tree is
begin
return Diana.Make (Diana.Dn_Package_Id, Subunit_Name);
end Make_Subunit_Name;
function Make_Subunit_Body (Subunit_Name : String) return Diana.Tree is
begin
return Diana.Make
(Diana.Dn_Package_Body, Make_Subunit_Name (Subunit_Name),
Diana.Make (Diana.Dn_Block,
Diana.Make (Diana.Dn_Item_S, Diana.Make),
Diana.Make (Diana.Dn_Stm_S, Diana.Make),
Diana.Make (Diana.Dn_Alternative_S,
Diana.Make)));
end Make_Subunit_Body;
function Make_Visible_Part (Subunit_Name : String) return Diana.Tree is
begin
return Diana.Make
(Diana.Dn_Package_Decl, Make_Subunit_Name (Subunit_Name),
Diana.Make (Diana.Dn_Package_Spec,
Diana.Make (Diana.Dn_Decl_S, Diana.Make),
Diana.Make (Diana.Dn_Decl_S, Diana.Make)));
end Make_Visible_Part;
procedure Find_Vis_Part (Subunit_Name : String;
Item_S : Diana.Tree;
Vispart : out Diana.Tree) is
Item : Diana.Tree;
Items : Diana.Seq_Type := Diana.List (Item_S);
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
if Diana.Kind (Item) = Diana.Dn_Package_Decl and then
Diana.Image (Diana.Id (Diana.As_Id (Item))) = Subunit_Name then
Vispart := Item;
return;
else
Items := Diana.Tail (Items);
end if;
end loop;
Vispart := Diana.Empty;
end Find_Vis_Part;
procedure Find_Stub_Decl (Subunit_Name : String;
Item_S : Diana.Tree;
Stub : out Diana.Tree;
Stub_Id : out Diana.Tree) is
Item : Diana.Tree;
Items : Diana.Seq_Type := Diana.List (Item_S);
Id : Diana.Tree;
begin
while not Diana.Is_Empty (Items) loop
Item := Diana.Head (Items);
if Diana.Kind (Item) = Diana.Dn_Package_Body and then
Diana.Kind (Diana.As_Block_Stub (Item)) = Diana.Dn_Stub then
Id := Diana.As_Id (Item);
if Diana.Image (Diana.Id (Id)) = Subunit_Name then
Stub := Item;
Stub_Id := Id;
return;
end if;
end if;
Items := Diana.Tail (Items);
end loop;
Stub := Diana.Empty;
Stub_Id := Diana.Empty;
end Find_Stub_Decl;
procedure Create_Subunit_Space (Wroot : Ada.Root;
Subunit_Name : String;
Vpart : out Diana.Tree;
Sroot : out Ada.Root;
The_Stub : out Diana.Tree;
Action_Id : Action.Id) is
Unit_Id : Diana.Tree := Diana.Id_Utilities.Get_Id (Wroot);
Status : Directory.Error_Status;
Item_S : Diana.Tree := Get_Items (Wroot);
Items : Diana.Seq_Type;
Stub : Diana.Tree;
Stub_Id : Diana.Tree;
Object : Directory.Object;
Subunit : Diana.Tree;
Vispart : Diana.Tree;
Key : Ada.Conversion_Key;
Subname : constant String := Get_Subunit_Name (Subunit_Name, Unit_Id);
begin
Ada.Set_Diana_Heap (Wroot, Status);
Check (Status, "setting diana heap to unit");
Find_Vis_Part (Subname, Item_S, Vispart);
if Diana.Is_Empty (Vispart) then
Vispart := Make_Visible_Part (Subname);
Insert_Visible_Part (Vispart, Item_S);
end if;
Find_Stub_Decl (Subname, Item_S, Stub, Stub_Id);
if Diana.Is_Empty (Stub) then
Items := Diana.List (Item_S);
Stub_Id := Make_Subunit_Name (Subname);
Stub := Diana.Make (Diana.Dn_Package_Body, Stub_Id,
Diana.Make (Diana.Dn_Stub));
Diana.List_Utilities.Nconc (Items, Stub);
end if;
Traversal.Get_Object (Stub_Id, Object, Status, Action_Id => Action_Id);
Check (Status, "getting object for new subunit stub");
Ada.Open (Ada.Get_Unit (Object), Ada.Update,
Subunit, Key, Status, Action_Id);
Check (Status, "opening space for subunit");
if Diana.Kind (Subunit) = Diana.Dn_Nonterminal then
Ada.Set_Diana_Heap (Subunit, Status);
Check (Status, "setting diana heap to new subunit");
Subunit := Make_Subunit_Body (Subname);
Ada.Set_Root (Subunit, Status, Action_Id);
Check (Status, "setting root of new subunit");
end if;
Sroot := Subunit;
Vpart := Vispart;
The_Stub := Stub;
end Create_Subunit_Space;
procedure Make_Subunit (Unit_To_Split : Ada_Unit_Name;
Unit_Sizes_To_Include : Stmt_Decl_Count := 0;
Subunits_To_Separate : String := "";
Subunit_Name : String := "") is
Def_Id : Directory.Declaration;
Root : Ada.Root;
Wroot : Ada.Root;
Kinds : Unit_Kinds := (others => True);
Status : Directory.Error_Status;
Old_Heap : Ada.Root;
Sroot : Ada.Root;
Vpart : Diana.Tree;
Stub : Diana.Tree;
Sep_Ids : Diana.Temp_Seq := Diana.Make;
Parent_Name : Diana.Symbol_Rep;
Sunit_Name : Diana.Symbol_Rep;
Action_Id : Action.Id := Action.Start;
begin
Log.Put_Line ("[Split.Make_Subunit, """ & Unit_To_Split & """," &
Integer'Image (Unit_Sizes_To_Include) & ", """ &
Subunits_To_Separate & """, """ & Subunit_Name & """]");
Ada.Get_Diana_Heap (Old_Heap, Status);
Check (Status, "getting old diana heap");
Find_Unit (Unit_To_Split, Def_Id);
Demote_Unit (Def_Id, Root, Action_Id);
Make_Writable (Root, Wroot, Action_Id);
Create_Subunit_Space (Wroot, String_Utilities.Upper_Case (Subunit_Name),
Vpart, Sroot, Stub, Action_Id);
if Subunits_To_Separate /= "" then
Process_Unit_List_Subunitize
(Wroot, Vpart, Sroot, Subunits_To_Separate,
Kinds, Action_Id, Sep_Ids);
else
Separate_Bodies_Into_Subunit
(Wroot, Vpart, Sroot, Unit_Sizes_To_Include,
Kinds, Action_Id, Sep_Ids);
end if;
Parent_Name := Diana.Id (Diana.Id_Utilities.Get_Id (Wroot));
Sunit_Name := Diana.Id (Diana.Id_Utilities.Get_Id (Stub));
Split_Util.Fix_References (Wroot, Stub, Sep_Ids, Action_Id,
Parent_Name, Sunit_Name, False);
Split_Util.Fix_References (Sroot, Diana.Empty, Sep_Ids, Action_Id,
Parent_Name, Sunit_Name, True);
Ada.Close (Sroot, Status, Action_Id);
Check (Status, "closing new subunit");
Ada.Close (Wroot, Status, Action_Id);
Check (Status, "closing unit");
Ada.Set_Diana_Heap (Old_Heap, Status);
Action.Finish (Action_Id, Do_Commit => True);
Log.Put_Line ("[end of Split.Make_Subunit]");
exception
when Failure =>
Action.Finish (Action_Id, Do_Commit => False);
Ada.Set_Diana_Heap (Old_Heap, Status);
Log.Put_Line ("[end of Split.Make_Subunit]");
when others =>
Action.Finish (Action_Id, Do_Commit => False);
Error ("Unexpected exception", False);
Ada.Set_Diana_Heap (Old_Heap, Status);
Log.Put_Line ("[end of Split.Make_Subunit]");
end Make_Subunit;
end Split;