[Ada] Forced elaboration order in Elaboration order v4.0
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) 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. From-SVN: r272987
This commit is contained in:
parent
336878fc11
commit
76b4158b8f
|
@ -1,3 +1,34 @@
|
|||
2019-07-03 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* 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.
|
||||
|
||||
2019-07-03 Bob Duff <duff@adacore.com>
|
||||
|
||||
* sem_ch3.adb (Access_Definition): The code was creating a
|
||||
|
|
|
@ -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
|
||||
|
||||
Last := Cur - 1;
|
||||
|
||||
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;
|
||||
|
||||
-- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
|
||||
-- again.
|
||||
|
||||
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;
|
||||
|
||||
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;
|
||||
|
||||
-- Skip past LF or CR/LF
|
||||
|
||||
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 Is_Spec then
|
||||
return Line (First .. Last) & "%s";
|
||||
elsif Is_Body then
|
||||
return Line (First .. Last) & "%b";
|
||||
else
|
||||
return Line;
|
||||
end if;
|
||||
end;
|
||||
end Get_Line;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Empty_Name : constant Unit_Name_Type := Name_Find ("");
|
||||
Prev_Unit : Unit_Id := No_Unit_Id;
|
||||
Cur_Line_Number : Logical_Line_Number;
|
||||
Error : Boolean := False;
|
||||
Iter : Forced_Units_Iterator;
|
||||
Prev_Unit : Unit_Id := No_Unit_Id;
|
||||
Uname : Unit_Name_Type;
|
||||
|
||||
-- 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.
|
||||
Iter := Iterate_Forced_Units;
|
||||
while Has_Next (Iter) loop
|
||||
Next (Iter, Uname, Cur_Line_Number);
|
||||
|
||||
while Cur <= S'Last loop
|
||||
declare
|
||||
Uname : constant Unit_Name_Type := Name_Find (Get_Line);
|
||||
Error : Boolean := False;
|
||||
|
||||
Dup : constant Logical_Line_Number := Name_Map.Get (Uname);
|
||||
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);
|
||||
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.
|
||||
-- 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;
|
||||
|
||||
else
|
||||
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;
|
||||
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;
|
||||
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
|
||||
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;
|
||||
|
||||
Prev_Unit := Cur_Unit;
|
||||
end if;
|
||||
end;
|
||||
else
|
||||
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 loop;
|
||||
|
||||
Free (S);
|
||||
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;
|
||||
|
||||
Prev_Unit := Cur_Unit;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end loop;
|
||||
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,
|
||||
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
|
||||
|
||||
-- This package contains utility routines for the binder
|
||||
|
||||
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.
|
||||
|
|
Loading…
Reference in New Issue