@@ -35,7 +35,6 @@ with Types; use Types;
with System.Case_Util; use System.Case_Util;
with System.HTable;
-with System.OS_Lib;
package body Binde is
use Unit_Id_Tables;
@@ -115,7 +114,7 @@ package body Binde is
-- elaborated before After is elaborated.
Forced,
- -- Before and After come from a pair of lines in the forced elaboration
+ -- Before and After come from a pair of lines in the forced-elaboration-
-- order file.
Elab,
@@ -382,7 +381,7 @@ package body Binde is
-- "$ must be elaborated before $ ..." where ... is the reason.
procedure Force_Elab_Order;
- -- Gather dependencies from the forced elaboration order file (-f switch)
+ -- Gather dependencies from the forced-elaboration-order file (-f switch)
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
@@ -1795,30 +1794,13 @@ package body Binde is
----------------------
procedure Force_Elab_Order is
- use System.OS_Lib;
- -- There is a lot of fiddly string manipulation below, because we don't
- -- want to depend on misc utility packages like Ada.Characters.Handling.
-
- function Get_Line return String;
- -- Read the next line from the file content read by Read_File. Strip
- -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
- -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
-
- function Read_File (Name : String) return String_Ptr;
- -- Read the entire contents of the named file
-
subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1;
- type Line_Number is new Nat;
- No_Line_Number : constant Line_Number := 0;
- Cur_Line_Number : Line_Number := 0;
- -- Current line number in the Force_Elab_Order_File.
- -- Incremented by Get_Line. Used in error messages.
function Hash (N : Unit_Name_Type) return Header_Num;
package Name_Map is new System.HTable.Simple_HTable
(Header_Num => Header_Num,
- Element => Line_Number,
+ Element => Logical_Line_Number,
No_Element => No_Line_Number,
Key => Unit_Name_Type,
Hash => Hash,
@@ -1839,234 +1821,86 @@ package body Binde is
return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1);
end Hash;
- ---------------
- -- Read_File --
- ---------------
-
- function Read_File (Name : String) return String_Ptr is
-
- -- All of the following calls should succeed, because we checked the
- -- file in Switch.B, but we double check and raise Program_Error on
- -- failure, just in case.
-
- F : constant File_Descriptor := Open_Read (Name, Binary);
-
- begin
- if F = Invalid_FD then
- raise Program_Error;
- end if;
-
- declare
- Len : constant Natural := Natural (File_Length (F));
- Result : constant String_Ptr := new String (1 .. Len);
- Len_Read : constant Natural :=
- Read (F, Result (1)'Address, Len);
-
- Status : Boolean;
-
- begin
- if Len_Read /= Len then
- raise Program_Error;
- end if;
-
- Close (F, Status);
-
- if not Status then
- raise Program_Error;
- end if;
-
- return Result;
- end;
- end Read_File;
-
- Cur : Positive := 1;
- S : String_Ptr := Read_File (Force_Elab_Order_File.all);
-
- --------------
- -- Get_Line --
- --------------
-
- function Get_Line return String is
- First : Positive := Cur;
- Last : Natural;
-
- begin
- Cur_Line_Number := Cur_Line_Number + 1;
-
- -- Skip to end of line
-
- while Cur <= S'Last
- and then S (Cur) /= ASCII.LF
- and then S (Cur) /= ASCII.CR
- loop
- Cur := Cur + 1;
- end loop;
-
- -- Strip leading blanks
-
- while First <= S'Last and then S (First) = ' ' loop
- First := First + 1;
- end loop;
-
- -- Strip trailing blanks and comment
+ -- Local variables
- Last := Cur - 1;
+ Cur_Line_Number : Logical_Line_Number;
+ Error : Boolean := False;
+ Iter : Forced_Units_Iterator;
+ Prev_Unit : Unit_Id := No_Unit_Id;
+ Uname : Unit_Name_Type;
- for J in First .. Last - 1 loop
- if S (J .. J + 1) = "--" then
- Last := J - 1;
- exit;
- end if;
- end loop;
-
- while Last >= First and then S (Last) = ' ' loop
- Last := Last - 1;
- end loop;
+ -- Start of processing for Force_Elab_Order
- -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
- -- again.
+ begin
+ Iter := Iterate_Forced_Units;
+ while Has_Next (Iter) loop
+ Next (Iter, Uname, Cur_Line_Number);
declare
- Body_String : constant String := "(body)";
- BL : constant Positive := Body_String'Length;
- Spec_String : constant String := "(spec)";
- SL : constant Positive := Spec_String'Length;
-
- Line : String renames S (First .. Last);
-
- Is_Body : Boolean := False;
- Is_Spec : Boolean := False;
-
+ Dup : constant Logical_Line_Number := Name_Map.Get (Uname);
begin
- if Line'Length >= SL
- and then Line (Last - SL + 1 .. Last) = Spec_String
- then
- Is_Spec := True;
- Last := Last - SL;
- elsif Line'Length >= BL
- and then Line (Last - BL + 1 .. Last) = Body_String
- then
- Is_Body := True;
- Last := Last - BL;
- end if;
-
- while Last >= First and then S (Last) = ' ' loop
- Last := Last - 1;
- end loop;
+ if Dup = No_Line_Number then
+ Name_Map.Set (Uname, Cur_Line_Number);
- -- Skip past LF or CR/LF
+ -- We don't need to give the "not present" message in the case
+ -- of "duplicate unit", because we would have already given the
+ -- "not present" message on the first occurrence.
- if Cur <= S'Last and then S (Cur) = ASCII.CR then
- Cur := Cur + 1;
- end if;
-
- if Cur <= S'Last and then S (Cur) = ASCII.LF then
- Cur := Cur + 1;
- end if;
+ if Get_Name_Table_Int (Uname) = 0
+ or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
+ then
+ Error := True;
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname)
+ & """: not present; ignored");
+ end if;
+ end if;
- if Is_Spec then
- return Line (First .. Last) & "%s";
- elsif Is_Body then
- return Line (First .. Last) & "%b";
else
- return Line;
+ Error := True;
+ if Doing_New then
+ Error_Msg_Nat_1 := Nat (Cur_Line_Number);
+ Error_Msg_Unit_1 := Uname;
+ Error_Msg_Nat_2 := Nat (Dup);
+ Error_Msg
+ (Force_Elab_Order_File.all
+ & ":#: duplicate unit name $ from line #");
+ end if;
end if;
end;
- end Get_Line;
- -- Local variables
-
- Empty_Name : constant Unit_Name_Type := Name_Find ("");
- Prev_Unit : Unit_Id := No_Unit_Id;
-
- -- Start of processing for Force_Elab_Order
-
- begin
- -- Loop through the file content, and build a dependency link for each
- -- pair of lines. Ignore lines that should be ignored.
-
- while Cur <= S'Last loop
- declare
- Uname : constant Unit_Name_Type := Name_Find (Get_Line);
- Error : Boolean := False;
-
- begin
- if Uname = Empty_Name then
- null; -- silently skip blank lines
- else
- declare
- Dup : constant Line_Number := Name_Map.Get (Uname);
- begin
- if Dup = No_Line_Number then
- Name_Map.Set (Uname, Cur_Line_Number);
-
- -- We don't need to give the "not present" message in
- -- the case of "duplicate unit", because we would have
- -- already given the "not present" message on the
- -- first occurrence.
-
- if Get_Name_Table_Int (Uname) = 0
- or else Unit_Id (Get_Name_Table_Int (Uname)) =
- No_Unit_Id
- then
- Error := True;
- if Doing_New then
- Write_Line
- ("""" & Get_Name_String (Uname)
- & """: not present; ignored");
- end if;
- end if;
+ if not Error then
+ declare
+ Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
+ begin
+ if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname)
+ & """: predefined unit ignored");
+ end if;
- else
- Error := True;
+ else
+ if Prev_Unit /= No_Unit_Id then
if Doing_New then
- Error_Msg_Nat_1 := Nat (Cur_Line_Number);
- Error_Msg_Unit_1 := Uname;
- Error_Msg_Nat_2 := Nat (Dup);
- Error_Msg
- (Force_Elab_Order_File.all
- & ":#: duplicate unit name $ from line #");
+ Write_Unit_Name (Units.Table (Prev_Unit).Uname);
+ Write_Str (" <-- ");
+ Write_Unit_Name (Units.Table (Cur_Unit).Uname);
+ Write_Eol;
end if;
- end if;
- end;
-
- if not Error then
- declare
- Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
- begin
- if Is_Internal_File_Name
- (Units.Table (Cur_Unit).Sfile)
- then
- if Doing_New then
- Write_Line
- ("""" & Get_Name_String (Uname)
- & """: predefined unit ignored");
- end if;
- else
- if Prev_Unit /= No_Unit_Id then
- if Doing_New then
- Write_Unit_Name (Units.Table (Prev_Unit).Uname);
- Write_Str (" <-- ");
- Write_Unit_Name (Units.Table (Cur_Unit).Uname);
- Write_Eol;
- end if;
-
- Build_Link
- (Before => Prev_Unit,
- After => Cur_Unit,
- R => Forced);
- end if;
+ Build_Link
+ (Before => Prev_Unit,
+ After => Cur_Unit,
+ R => Forced);
+ end if;
- Prev_Unit := Cur_Unit;
- end if;
- end;
+ Prev_Unit := Cur_Unit;
end if;
- end if;
- end;
+ end;
+ end if;
end loop;
-
- Free (S);
end Force_Elab_Order;
-------------------------
@@ -23,8 +23,17 @@
-- --
------------------------------------------------------------------------------
+with Binderr; use Binderr;
+with Butil; use Butil;
+with Opt; use Opt;
+with Output; use Output;
+with Types; use Types;
+
with Bindo.Units; use Bindo.Units;
+with GNAT; use GNAT;
+with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
+
package body Bindo.Builders is
-------------------------------
@@ -214,16 +223,63 @@ package body Bindo.Builders is
package body Library_Graph_Builders is
+ ---------------------
+ -- Data structures --
+ ---------------------
+
+ procedure Destroy_Line_Number (Line : in out Logical_Line_Number);
+ pragma Inline (Destroy_Line_Number);
+ -- Destroy line number Line
+
+ function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type;
+ pragma Inline (Hash_Unit);
+ -- Obtain the hash value of key U_Id
+
+ package UL is new Dynamic_Hash_Tables
+ (Key_Type => Unit_Id,
+ Value_Type => Logical_Line_Number,
+ No_Value => No_Line_Number,
+ Expansion_Threshold => 1.5,
+ Expansion_Factor => 2,
+ Compression_Threshold => 0.3,
+ Compression_Factor => 2,
+ "=" => "=",
+ Destroy_Value => Destroy_Line_Number,
+ Hash => Hash_Unit);
+
-----------------
-- Global data --
-----------------
Lib_Graph : Library_Graph := Library_Graphs.Nil;
+ Unit_To_Line : UL.Dynamic_Hash_Table := UL.Nil;
+ -- The map of unit name -> line number, used to detect duplicate unit
+ -- names and report errors.
+
-----------------------
-- Local subprograms --
-----------------------
+ procedure Add_Unit
+ (U_Id : Unit_Id;
+ Line : Logical_Line_Number);
+ pragma Inline (Add_Unit);
+ -- Create a relationship between unit U_Id and its declaration line in
+ -- map Unit_To_Line.
+
+ procedure Create_Forced_Edge
+ (Pred : Unit_Id;
+ Succ : Unit_Id);
+ pragma Inline (Create_Forced_Edge);
+ -- Create a new forced edge between predecessor unit Pred and successor
+ -- unit Succ.
+
+ procedure Create_Forced_Edges;
+ pragma Inline (Create_Forced_Edges);
+ -- Inspect the contents of the forced-elaboration-order file, and create
+ -- specialized edges for each valid pair of units listed within.
+
procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id);
pragma Inline (Create_Spec_And_Body_Edge);
-- Establish a link between the spec and body of unit U_Id. In certain
@@ -255,10 +311,46 @@ package body Bindo.Builders is
-- some withed unit, and the successor is Succ. The edges are added to
-- library graph Lib_Graph.
+ procedure Duplicate_Unit_Error
+ (U_Id : Unit_Id;
+ Nam : Unit_Name_Type;
+ Line : Logical_Line_Number);
+ pragma Inline (Duplicate_Unit_Error);
+ -- Emit an error concerning the duplication of unit U_Id with name Nam
+ -- that is redeclared in the forced-elaboration-order file at line Line.
+
+ procedure Internal_Unit_Info (Nam : Unit_Name_Type);
+ pragma Inline (Internal_Unit_Info);
+ -- Emit an information message concerning the omission of an internal
+ -- unit with name Nam from the creation of forced edges.
+
+ function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean;
+ pragma Inline (Is_Duplicate_Unit);
+ -- Determine whether unit U_Id is already recorded in map Unit_To_Line
+
function Is_Significant_With (W_Id : With_Id) return Boolean;
pragma Inline (Is_Significant_With);
-- Determine whether with W_Id plays a significant role in elaboration
+ procedure Missing_Unit_Info (Nam : Unit_Name_Type);
+ pragma Inline (Missing_Unit_Info);
+ -- Emit an information message concerning the omission of an undefined
+ -- unit found in the forced-elaboration-order file.
+
+ --------------
+ -- Add_Unit --
+ --------------
+
+ procedure Add_Unit
+ (U_Id : Unit_Id;
+ Line : Logical_Line_Number)
+ is
+ begin
+ pragma Assert (Present (U_Id));
+
+ UL.Put (Unit_To_Line, U_Id, Line);
+ end Add_Unit;
+
-------------------------
-- Build_Library_Graph --
-------------------------
@@ -275,9 +367,96 @@ package body Bindo.Builders is
For_Each_Elaborable_Unit (Create_Spec_And_Body_Edge'Access);
For_Each_Elaborable_Unit (Create_With_Edges'Access);
+ Create_Forced_Edges;
+
return Lib_Graph;
end Build_Library_Graph;
+ ------------------------
+ -- Create_Forced_Edge --
+ ------------------------
+
+ procedure Create_Forced_Edge
+ (Pred : Unit_Id;
+ Succ : Unit_Id)
+ is
+ pragma Assert (Present (Pred));
+ pragma Assert (Present (Succ));
+
+ Pred_LGV_Id : constant Library_Graph_Vertex_Id :=
+ Corresponding_Vertex (Lib_Graph, Pred);
+ Succ_LGV_Id : constant Library_Graph_Vertex_Id :=
+ Corresponding_Vertex (Lib_Graph, Succ);
+
+ pragma Assert (Present (Pred_LGV_Id));
+ pragma Assert (Present (Succ_LGV_Id));
+
+ begin
+ Write_Unit_Name (Name (Pred));
+ Write_Str (" <-- ");
+ Write_Unit_Name (Name (Succ));
+ Write_Eol;
+
+ Add_Edge
+ (G => Lib_Graph,
+ Pred => Pred_LGV_Id,
+ Succ => Succ_LGV_Id,
+ Kind => Forced_Edge);
+ end Create_Forced_Edge;
+
+ -------------------------
+ -- Create_Forced_Edges --
+ -------------------------
+
+ procedure Create_Forced_Edges is
+ Curr_Unit : Unit_Id;
+ Iter : Forced_Units_Iterator;
+ Prev_Unit : Unit_Id;
+ Unit_Line : Logical_Line_Number;
+ Unit_Name : Unit_Name_Type;
+
+ begin
+ Prev_Unit := No_Unit_Id;
+ Unit_To_Line := UL.Create (20);
+
+ -- Inspect the contents of the forced-elaboration-order file supplied
+ -- to the binder using switch -f, and diagnose each unit accordingly.
+
+ Iter := Iterate_Forced_Units;
+ while Has_Next (Iter) loop
+ Next (Iter, Unit_Name, Unit_Line);
+ pragma Assert (Present (Unit_Name));
+
+ Curr_Unit := Corresponding_Unit (Unit_Name);
+
+ if not Present (Curr_Unit) then
+ Missing_Unit_Info (Unit_Name);
+
+ elsif Is_Internal_Unit (Curr_Unit) then
+ Internal_Unit_Info (Unit_Name);
+
+ elsif Is_Duplicate_Unit (Curr_Unit) then
+ Duplicate_Unit_Error (Curr_Unit, Unit_Name, Unit_Line);
+
+ -- Otherwise the unit is a valid candidate for a vertex. Create a
+ -- forced edge between each pair of units.
+
+ else
+ Add_Unit (Curr_Unit, Unit_Line);
+
+ if Present (Prev_Unit) then
+ Create_Forced_Edge
+ (Pred => Prev_Unit,
+ Succ => Curr_Unit);
+ end if;
+
+ Prev_Unit := Curr_Unit;
+ end if;
+ end loop;
+
+ UL.Destroy (Unit_To_Line);
+ end Create_Forced_Edges;
+
-------------------------------
-- Create_Spec_And_Body_Edge --
-------------------------------
@@ -453,6 +632,75 @@ package body Bindo.Builders is
end loop;
end Create_With_Edges;
+ ------------------
+ -- Destroy_Unit --
+ ------------------
+
+ procedure Destroy_Line_Number (Line : in out Logical_Line_Number) is
+ pragma Unreferenced (Line);
+ begin
+ null;
+ end Destroy_Line_Number;
+
+ --------------------------
+ -- Duplicate_Unit_Error --
+ --------------------------
+
+ procedure Duplicate_Unit_Error
+ (U_Id : Unit_Id;
+ Nam : Unit_Name_Type;
+ Line : Logical_Line_Number)
+ is
+ pragma Assert (Present (U_Id));
+ pragma Assert (Present (Nam));
+
+ Prev_Line : constant Logical_Line_Number :=
+ UL.Get (Unit_To_Line, U_Id);
+
+ begin
+ Error_Msg_Nat_1 := Nat (Line);
+ Error_Msg_Nat_2 := Nat (Prev_Line);
+ Error_Msg_Unit_1 := Nam;
+
+ Error_Msg
+ (Force_Elab_Order_File.all
+ & ":#: duplicate unit name $ from line #");
+ end Duplicate_Unit_Error;
+
+ ---------------
+ -- Hash_Unit --
+ ---------------
+
+ function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type is
+ begin
+ pragma Assert (Present (U_Id));
+
+ return Bucket_Range_Type (U_Id);
+ end Hash_Unit;
+
+ ------------------------
+ -- Internal_Unit_Info --
+ ------------------------
+
+ procedure Internal_Unit_Info (Nam : Unit_Name_Type) is
+ begin
+ pragma Assert (Present (Nam));
+
+ Write_Line
+ ("""" & Get_Name_String (Nam) & """: predefined unit ignored");
+ end Internal_Unit_Info;
+
+ -----------------------
+ -- Is_Duplicate_Unit --
+ -----------------------
+
+ function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean is
+ begin
+ pragma Assert (Present (U_Id));
+
+ return UL.Contains (Unit_To_Line, U_Id);
+ end Is_Duplicate_Unit;
+
-------------------------
-- Is_Significant_With --
-------------------------
@@ -483,6 +731,18 @@ package body Bindo.Builders is
return True;
end Is_Significant_With;
+
+ -----------------------
+ -- Missing_Unit_Info --
+ -----------------------
+
+ procedure Missing_Unit_Info (Nam : Unit_Name_Type) is
+ begin
+ pragma Assert (Present (Nam));
+
+ Write_Line
+ ("""" & Get_Name_String (Nam) & """: not present; ignored");
+ end Missing_Unit_Info;
end Library_Graph_Builders;
end Bindo.Builders;
@@ -2069,10 +2069,8 @@ package body Bindo.Graphs is
pragma Assert (Present (U_Id));
- U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
-
begin
- return U_Rec.Internal;
+ return Is_Internal_Unit (U_Id);
end Is_Internal_Unit;
------------------------
@@ -2090,10 +2088,8 @@ package body Bindo.Graphs is
pragma Assert (Present (U_Id));
- U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
-
begin
- return U_Rec.Predefined;
+ return Is_Predefined_Unit (U_Id);
end Is_Predefined_Unit;
---------------------------
@@ -573,7 +573,7 @@ package Bindo.Graphs is
Elaborate_All_Edge,
-- Successor withs Predecessor, and has pragma Elaborate_All for it
+ Forced_Edge,
-- Successor is forced to with Predecessor by virtue of an existing
-- elaboration order provided in a file.
@@ -233,6 +233,32 @@ package body Bindo.Units is
return U_Rec.Dynamic_Elab;
end Is_Dynamically_Elaborated;
+ ----------------------
+ -- Is_Internal_Unit --
+ ----------------------
+
+ function Is_Internal_Unit (U_Id : Unit_Id) return Boolean is
+ pragma Assert (Present (U_Id));
+
+ U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
+
+ begin
+ return U_Rec.Internal;
+ end Is_Internal_Unit;
+
+ ------------------------
+ -- Is_Predefined_Unit --
+ ------------------------
+
+ function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean is
+ pragma Assert (Present (U_Id));
+
+ U_Rec : Unit_Record renames ALI.Units.Table (U_Id);
+
+ begin
+ return U_Rec.Predefined;
+ end Is_Predefined_Unit;
+
---------------------------------
-- Is_Stand_Alone_Library_Unit --
---------------------------------
@@ -78,6 +78,14 @@ package Bindo.Units is
-- Determine whether unit U_Id was compiled using the dynamic elaboration
-- model.
+ function Is_Internal_Unit (U_Id : Unit_Id) return Boolean;
+ pragma Inline (Is_Internal_Unit);
+ -- Determine whether unit U_Id is internal
+
+ function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean;
+ pragma Inline (Is_Predefined_Unit);
+ -- Determine whether unit U_Id is predefined
+
function Name (U_Id : Unit_Id) return Unit_Name_Type;
pragma Inline (Name);
-- Obtain the name of unit U_Id
@@ -23,10 +23,38 @@
-- --
------------------------------------------------------------------------------
+with Opt; use Opt;
with Output; use Output;
+with Unchecked_Deallocation;
+
+with GNAT; use GNAT;
+
+with System.OS_Lib; use System.OS_Lib;
package body Butil is
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator);
+ -- Parse the name of the next available unit accessible through iterator
+ -- Iter and save it in the iterator.
+
+ function Read_Forced_Elab_Order_File return String_Ptr;
+ -- Read the contents of the forced-elaboration-order file supplied to the
+ -- binder via switch -f and return them as a string. Return null if the
+ -- file is not available.
+
+ --------------
+ -- Has_Next --
+ --------------
+
+ function Has_Next (Iter : Forced_Units_Iterator) return Boolean is
+ begin
+ return Present (Iter.Unit_Name);
+ end Has_Next;
+
----------------------
-- Is_Internal_Unit --
----------------------
@@ -71,6 +99,499 @@ package body Butil is
or else (L > 4 and then B (1 .. 5) = "gnat.");
end Is_Predefined_Unit;
+ --------------------------
+ -- Iterate_Forced_Units --
+ --------------------------
+
+ function Iterate_Forced_Units return Forced_Units_Iterator is
+ Iter : Forced_Units_Iterator;
+
+ begin
+ Iter.Order := Read_Forced_Elab_Order_File;
+ Parse_Next_Unit_Name (Iter);
+
+ return Iter;
+ end Iterate_Forced_Units;
+
+ ----------
+ -- Next --
+ ----------
+
+ procedure Next
+ (Iter : in out Forced_Units_Iterator;
+ Unit_Name : out Unit_Name_Type;
+ Unit_Line : out Logical_Line_Number)
+ is
+ begin
+ if not Has_Next (Iter) then
+ raise Iterator_Exhausted;
+ end if;
+
+ Unit_Line := Iter.Unit_Line;
+ Unit_Name := Iter.Unit_Name;
+ pragma Assert (Present (Unit_Name));
+
+ Parse_Next_Unit_Name (Iter);
+ end Next;
+
+ --------------------------
+ -- Parse_Next_Unit_Name --
+ --------------------------
+
+ procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is
+ Body_Suffix : constant String := " (body)";
+ Body_Type : constant String := "%b";
+ Body_Length : constant Positive := Body_Suffix'Length;
+ Body_Offset : constant Natural := Body_Length - 1;
+
+ Comment_Header : constant String := "--";
+ Comment_Offset : constant Natural := Comment_Header'Length - 1;
+
+ Spec_Suffix : constant String := " (spec)";
+ Spec_Type : constant String := "%s";
+ Spec_Length : constant Positive := Spec_Suffix'Length;
+ Spec_Offset : constant Natural := Spec_Length - 1;
+
+ Index : Positive renames Iter.Order_Index;
+ Line : Logical_Line_Number renames Iter.Order_Line;
+ Order : String_Ptr renames Iter.Order;
+
+ function At_Comment return Boolean;
+ pragma Inline (At_Comment);
+ -- Determine whether iterator Iter is positioned over the start of a
+ -- comment.
+
+ function At_Terminator return Boolean;
+ pragma Inline (At_Terminator);
+ -- Determine whether iterator Iter is positioned over a line terminator
+ -- character.
+
+ function At_Whitespace return Boolean;
+ pragma Inline (At_Whitespace);
+ -- Determine whether iterator Iter is positioned over a whitespace
+ -- character.
+
+ function Is_Terminator (C : Character) return Boolean;
+ pragma Inline (Is_Terminator);
+ -- Determine whether character C denotes a line terminator
+
+ function Is_Whitespace (C : Character) return Boolean;
+ pragma Inline (Is_Whitespace);
+ -- Determine whether character C denotes a whitespace
+
+ procedure Parse_Unit_Name;
+ pragma Inline (Parse_Unit_Name);
+ -- Find and parse the first available unit name
+
+ procedure Skip_Comment;
+ pragma Inline (Skip_Comment);
+ -- Skip a comment by reaching a line terminator
+
+ procedure Skip_Terminator;
+ pragma Inline (Skip_Terminator);
+ -- Skip a line terminator and deal with the logical line numbering
+
+ procedure Skip_Whitespace;
+ pragma Inline (Skip_Whitespace);
+ -- Skip whitespace
+
+ function Within_Order
+ (Low_Offset : Natural := 0;
+ High_Offset : Natural := 0) return Boolean;
+ pragma Inline (Within_Order);
+ -- Determine whether index of iterator Iter is still within the range of
+ -- the order string. Low_Offset may be used to inspect the area that is
+ -- less than the index. High_Offset may be used to inspect the area that
+ -- is greater than the index.
+
+ ----------------
+ -- At_Comment --
+ ----------------
+
+ function At_Comment return Boolean is
+ begin
+ -- The interator is over a comment when the index is positioned over
+ -- the start of a comment header.
+ --
+ -- unit (spec) -- comment
+ -- ^
+ -- Index
+
+ return
+ Within_Order (High_Offset => Comment_Offset)
+ and then Order (Index .. Index + Comment_Offset) = Comment_Header;
+ end At_Comment;
+
+ -------------------
+ -- At_Terminator --
+ -------------------
+
+ function At_Terminator return Boolean is
+ begin
+ return Within_Order and then Is_Terminator (Order (Index));
+ end At_Terminator;
+
+ -------------------
+ -- At_Whitespace --
+ -------------------
+
+ function At_Whitespace return Boolean is
+ begin
+ return Within_Order and then Is_Whitespace (Order (Index));
+ end At_Whitespace;
+
+ -------------------
+ -- Is_Terminator --
+ -------------------
+
+ function Is_Terminator (C : Character) return Boolean is
+ begin
+ -- Carriage return is treated intentionally as whitespace since it
+ -- appears only on certain targets, while line feed is consistent on
+ -- all of them.
+
+ return C = ASCII.LF;
+ end Is_Terminator;
+
+ -------------------
+ -- Is_Whitespace --
+ -------------------
+
+ function Is_Whitespace (C : Character) return Boolean is
+ begin
+ return
+ C = ' '
+ or else C = ASCII.CR -- carriage return
+ or else C = ASCII.FF -- form feed
+ or else C = ASCII.HT -- horizontal tab
+ or else C = ASCII.VT; -- vertical tab
+ end Is_Whitespace;
+
+ ---------------------
+ -- Parse_Unit_Name --
+ ---------------------
+
+ procedure Parse_Unit_Name is
+ pragma Assert (not At_Comment);
+ pragma Assert (not At_Terminator);
+ pragma Assert (not At_Whitespace);
+ pragma Assert (Within_Order);
+
+ procedure Find_End_Index_Of_Unit_Name;
+ pragma Inline (Find_End_Index_Of_Unit_Name);
+ -- Position the index of iterator Iter at the last character of the
+ -- first available unit name.
+
+ ---------------------------------
+ -- Find_End_Index_Of_Unit_Name --
+ ---------------------------------
+
+ procedure Find_End_Index_Of_Unit_Name is
+ begin
+ -- At this point the index points at the start of a unit name. The
+ -- unit name may be legal, in which case it appears as:
+ --
+ -- unit (body)
+ --
+ -- However, it may also be illegal:
+ --
+ -- unit without suffix
+ -- unit with multiple prefixes (spec)
+ --
+ -- In order to handle both forms, find the construct following the
+ -- unit name. This is either a comment, a terminator, or the end
+ -- of the order:
+ --
+ -- unit (body) -- comment
+ -- unit without suffix <terminator>
+ -- unit with multiple prefixes (spec)<end of order>
+ --
+ -- Once the construct is found, truncate the unit name by skipping
+ -- all white space between the construct and the end of the unit
+ -- name.
+
+ -- Find the construct that follows the unit name
+
+ while Within_Order loop
+ if At_Comment then
+ exit;
+
+ elsif At_Terminator then
+ exit;
+ end if;
+
+ Index := Index + 1;
+ end loop;
+
+ -- Position the index prior to the construct that follows the unit
+ -- name.
+
+ Index := Index - 1;
+
+ -- Truncate towards the end of the unit name
+
+ while Within_Order loop
+ if At_Whitespace then
+ Index := Index - 1;
+ else
+ exit;
+ end if;
+ end loop;
+ end Find_End_Index_Of_Unit_Name;
+
+ -- Local variables
+
+ Start_Index : constant Positive := Index;
+
+ End_Index : Positive;
+ Is_Body : Boolean := False;
+ Is_Spec : Boolean := False;
+
+ -- Start of processing for Parse_Unit_Name
+
+ begin
+ Find_End_Index_Of_Unit_Name;
+ End_Index := Index;
+
+ pragma Assert (Start_Index <= End_Index);
+
+ -- At this point the indices are positioned as follows:
+ --
+ -- End_Index
+ -- Index
+ -- v
+ -- unit (spec) -- comment
+ -- ^
+ -- Start_Index
+
+ -- Rewind the index, skipping over the legal suffixes
+ --
+ -- Index End_Index
+ -- v v
+ -- unit (spec) -- comment
+ -- ^
+ -- Start_Index
+
+ if Within_Order (Low_Offset => Body_Offset)
+ and then Order (Index - Body_Offset .. Index) = Body_Suffix
+ then
+ Is_Body := True;
+ Index := Index - Body_Length;
+
+ elsif Within_Order (Low_Offset => Spec_Offset)
+ and then Order (Index - Spec_Offset .. Index) = Spec_Suffix
+ then
+ Is_Spec := True;
+ Index := Index - Spec_Length;
+ end if;
+
+ -- Capture the line where the unit name is defined
+
+ Iter.Unit_Line := Line;
+
+ -- Transform the unit name to match the format recognized by the
+ -- name table.
+
+ if Is_Body then
+ Iter.Unit_Name :=
+ Name_Find (Order (Start_Index .. Index) & Body_Type);
+
+ elsif Is_Spec then
+ Iter.Unit_Name :=
+ Name_Find (Order (Start_Index .. Index) & Spec_Type);
+
+ -- Otherwise the unit name is illegal, so leave it as is
+
+ else
+ Iter.Unit_Name := Name_Find (Order (Start_Index .. Index));
+ end if;
+
+ -- Advance the index past the unit name
+ --
+ -- End_IndexIndex
+ -- vv
+ -- unit (spec) -- comment
+ -- ^
+ -- Start_Index
+
+ Index := End_Index + 1;
+ end Parse_Unit_Name;
+
+ ------------------
+ -- Skip_Comment --
+ ------------------
+
+ procedure Skip_Comment is
+ begin
+ pragma Assert (At_Comment);
+
+ while Within_Order loop
+ if At_Terminator then
+ exit;
+ end if;
+
+ Index := Index + 1;
+ end loop;
+ end Skip_Comment;
+
+ ---------------------
+ -- Skip_Terminator --
+ ---------------------
+
+ procedure Skip_Terminator is
+ begin
+ pragma Assert (At_Terminator);
+
+ Index := Index + 1;
+ Line := Line + 1;
+ end Skip_Terminator;
+
+ ---------------------
+ -- Skip_Whitespace --
+ ---------------------
+
+ procedure Skip_Whitespace is
+ begin
+ while Within_Order loop
+ if At_Whitespace then
+ Index := Index + 1;
+ else
+ exit;
+ end if;
+ end loop;
+ end Skip_Whitespace;
+
+ ------------------
+ -- Within_Order --
+ ------------------
+
+ function Within_Order
+ (Low_Offset : Natural := 0;
+ High_Offset : Natural := 0) return Boolean
+ is
+ begin
+ return
+ Order /= null
+ and then Index - Low_Offset >= Order'First
+ and then Index + High_Offset <= Order'Last;
+ end Within_Order;
+
+ -- Start of processing for Parse_Next_Unit_Name
+
+ begin
+ -- A line in the forced-elaboration-order file has the following
+ -- grammar:
+ --
+ -- LINE ::=
+ -- [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR
+ --
+ -- WHITESPACE ::=
+ -- <any whitespace character>
+ -- | <carriage return>
+ --
+ -- UNIT_NAME ::=
+ -- UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX
+ --
+ -- UNIT_PREFIX ::=
+ -- <any string>
+ --
+ -- UNIT_SUFFIX ::=
+ -- (body)
+ -- | (spec)
+ --
+ -- COMMENT ::=
+ -- -- <any string>
+ --
+ -- TERMINATOR ::=
+ -- <line feed>
+ -- <end of file>
+ --
+ -- Items in <> brackets are semantic notions
+
+ -- Assume that the order has no remaining units
+
+ Iter.Unit_Line := No_Line_Number;
+ Iter.Unit_Name := No_Unit_Name;
+
+ -- Try to find the first available unit name from the current position
+ -- of iteration.
+
+ while Within_Order loop
+ Skip_Whitespace;
+
+ if At_Comment then
+ Skip_Comment;
+
+ elsif not Within_Order then
+ exit;
+
+ elsif At_Terminator then
+ Skip_Terminator;
+
+ else
+ Parse_Unit_Name;
+ exit;
+ end if;
+ end loop;
+ end Parse_Next_Unit_Name;
+
+ ---------------------------------
+ -- Read_Forced_Elab_Order_File --
+ ---------------------------------
+
+ function Read_Forced_Elab_Order_File return String_Ptr is
+ procedure Free is new Unchecked_Deallocation (String, String_Ptr);
+
+ Descr : File_Descriptor;
+ Len : Natural;
+ Len_Read : Natural;
+ Result : String_Ptr;
+ Success : Boolean;
+
+ begin
+ if Force_Elab_Order_File = null then
+ return null;
+ end if;
+
+ -- Obtain and sanitize a descriptor to the elaboration-order file
+
+ Descr := Open_Read (Force_Elab_Order_File.all, Binary);
+
+ if Descr = Invalid_FD then
+ return null;
+ end if;
+
+ -- Determine the size of the file, allocate a result large enough to
+ -- house its contents, and read it.
+
+ Len := Natural (File_Length (Descr));
+
+ if Len = 0 then
+ return null;
+ end if;
+
+ Result := new String (1 .. Len);
+ Len_Read := Read (Descr, Result (1)'Address, Len);
+
+ -- The read failed to acquire the whole content of the file
+
+ if Len_Read /= Len then
+ Free (Result);
+ return null;
+ end if;
+
+ Close (Descr, Success);
+
+ -- The file failed to close
+
+ if not Success then
+ Free (Result);
+ return null;
+ end if;
+
+ return Result;
+ end Read_Forced_Elab_Order_File;
+
----------------
-- Uname_Less --
----------------
@@ -23,12 +23,13 @@
-- --
------------------------------------------------------------------------------
+-- This package contains utility routines for the binder
+
with Namet; use Namet;
+with Types; use Types;
package Butil is
-
function Is_Predefined_Unit return Boolean;
-- Given a unit name stored in Name_Buffer with length in Name_Len,
-- returns True if this is the name of a predefined unit or a child of
@@ -51,4 +52,52 @@ package Butil is
-- Output unit name with (body) or (spec) after as required. On return
-- Name_Len is set to the number of characters which were output.
+ ---------------
+ -- Iterators --
+ ---------------
+
+ -- The following type represents an iterator over all units that are
+ -- specified in the forced-elaboration-order file supplied by the binder
+ -- via switch -f.
+
+ type Forced_Units_Iterator is private;
+
+ function Has_Next (Iter : Forced_Units_Iterator) return Boolean;
+ pragma Inline (Has_Next);
+ -- Determine whether iterator Iter has more units to examine
+
+ function Iterate_Forced_Units return Forced_Units_Iterator;
+ pragma Inline (Iterate_Forced_Units);
+ -- Obtain an iterator over all units in the forced-elaboration-order file
+
+ procedure Next
+ (Iter : in out Forced_Units_Iterator;
+ Unit_Name : out Unit_Name_Type;
+ Unit_Line : out Logical_Line_Number);
+ pragma Inline (Next);
+ -- Return the current unit referenced by iterator Iter along with the
+ -- line number it appears on, and advance to the next available unit.
+
+private
+ First_Line_Number : constant Logical_Line_Number := No_Line_Number + 1;
+
+ type Forced_Units_Iterator is record
+ Order : String_Ptr := null;
+ -- A reference to the contents of the forced-elaboration-order file,
+ -- read in as a string.
+
+ Order_Index : Positive := 1;
+ -- Index into the order string
+
+ Order_Line : Logical_Line_Number := First_Line_Number;
+ -- Logical line number within the order string
+
+ Unit_Line : Logical_Line_Number := No_Line_Number;
+ -- The logical line number of the current unit name within the order
+ -- string.
+
+ Unit_Name : Unit_Name_Type := No_Unit_Name;
+ -- The current unit name parsed from the order string
+ end record;
+
end Butil;
@@ -1515,6 +1515,15 @@ package body Namet is
return Nam /= No_Name;
end Present;
+ -------------
+ -- Present --
+ -------------
+
+ function Present (Nam : Unit_Name_Type) return Boolean is
+ begin
+ return Nam /= No_Unit_Name;
+ end Present;
+
------------------
-- Reinitialize --
------------------
@@ -658,6 +658,10 @@ package Namet is
No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name);
-- Constant used to indicate no file name present
+ function Present (Nam : Unit_Name_Type) return Boolean;
+ pragma Inline (Present);
+ -- Determine whether unit name Nam exists
+
Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name);
-- The special Unit_Name_Type value Error_Unit_Name is used to indicate
-- a unit name where some previous processing has found an error.
This patch refactors the forced elaboration order functionality, reintegrates it in Binde, and impelements it in Bindo. ------------ -- Source -- ------------ -- server.ads package Server is end Server; -- client.ads with Server; package Client is end Client; -- main.adb with Client; procedure Main is begin null; end Main; -- duplicate_1.txt server (spec) client (spec) server (spec) -- error_unit_1.txt no such unit client (spec) -- error_unit_2.txt no such unit client (spec) -- error_unit_3.txt no such unit -- comment client (spec) -- error_unit_4.txt no such unit -- comment client (spec) -- error_unit_5.txt no such unit (body) client (spec) -- error_unit_6.txt no such unit (body) client (spec) -- error_unit_7.txt no such unit (body) -- comment client (spec) -- error_unit_8.txt no such unit (body)-- comment client (spec) -- error_unit_9.txt no such unit-- comment client (spec) -- no_unit_1.txt -- no_unit_2.txt -- no_unit_3.txt -- comment -- no_unit_4.txt -- no_unit_5.txt -- no_unit_6.txt -- comment -- no_unit_7.txt -- no_unit_8.txt -- comment -- comment -- ok_unit_1.txt server (spec) client (spec) -- ok_unit_2.txt server (spec) client (spec) -- ok_unit_3.txt server (spec) client (spec) -- ok_unit_4.txt server (spec) -- comment client (spec) -- ok_unit_5.txt server (spec) client (spec) -- ok_unit_6.txt server (spec) client (spec) -- comment -- ok_unit_7.txt server (spec) client (spec) -- comment -- ok_unit_8.txt -- comment -- comment server (spec) -- comment -- comment client (spec) -- comment -- ok_unit_9.txt server (spec)-- comment client (spec) ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ gnatbind -fno_unit_1.txt main.ali $ gnatbind -fno_unit_2.txt main.ali $ gnatbind -fno_unit_3.txt main.ali $ gnatbind -fno_unit_4.txt main.ali $ gnatbind -fno_unit_5.txt main.ali $ gnatbind -fno_unit_6.txt main.ali $ gnatbind -fno_unit_7.txt main.ali $ gnatbind -fno_unit_8.txt main.ali $ gnatbind -ferror_unit_1.txt main.ali $ gnatbind -ferror_unit_2.txt main.ali $ gnatbind -ferror_unit_3.txt main.ali $ gnatbind -ferror_unit_4.txt main.ali $ gnatbind -ferror_unit_5.txt main.ali $ gnatbind -ferror_unit_6.txt main.ali $ gnatbind -ferror_unit_7.txt main.ali $ gnatbind -ferror_unit_8.txt main.ali $ gnatbind -ferror_unit_9.txt main.ali $ gnatbind -fduplicate_1.txt main.ali $ gnatbind -fok_unit_1.txt main.ali $ gnatbind -fok_unit_2.txt main.ali $ gnatbind -fok_unit_3.txt main.ali $ gnatbind -fok_unit_4.txt main.ali $ gnatbind -fok_unit_5.txt main.ali $ gnatbind -fok_unit_6.txt main.ali $ gnatbind -fok_unit_7.txt main.ali $ gnatbind -fok_unit_8.txt main.ali $ gnatbind -fok_unit_9.txt main.ali "no such unit": not present; ignored "no such unit": not present; ignored "no such unit": not present; ignored "no such unit": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit": not present; ignored server (spec) <-- client (spec) error: duplicate_1.txt:3: duplicate unit name "server (spec)" from line 1 server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) Tested on x86_64-pc-linux-gnu, committed on trunk 2019-07-03 Hristian Kirtchev <kirtchev@adacore.com> gcc/ada/ * binde.adb: Remove with clause for System.OS_Lib. (Force_Elab_Order): Refactor the majority of the code in Butil. Use the new forced units iterator to obtain unit names. * bindo-builders.adb: Add with and use clauses for Binderr, Butil, Opt, Output, Types, GNAT, and GNAT.Dynamic_HTables. Add a hash table which maps units to line number in the forced elaboration order file. (Add_Unit): New routine. (Build_Library_Graph): Create forced edges between pairs of units listed in the forced elaboration order file. (Create_Forced_Edge, Create_Forced_Edges, Destroy_Line_Number, Duplicate_Unit_Error, Hash_Unit, Internal_Unit_Info, Is_Duplicate_Unit, Missing_Unit_Info): New routines. * bindo-graphs.adb (Is_Internal_Unit, Is_Predefined_Unit): Refactor some of the behavior to Bindo-Units. * bindo-graphs.ads: Enable the enumeration literal for forced edges. * bindo-units.adb, bindo-units.ads (Is_Internal_Unit, Is_Predefined_Unit): New routines. * butil.adb: Add with and use clauses for Opt, GNAT, and System.OS_Lib. Add with clause for Unchecked_Deallocation. (Has_Next, Iterate_Forced_Units, Next, Parse_Next_Unit_Name, Read_Forced_Elab_Order_File): New routines. * butil.ads: Add with and use clauses for Types. Add new iterator over the units listed in the forced elaboration order file. (Has_Next, Iterate_Forced_Units, Next): New routine. * namet.adb, namet.ads (Present): New routine.