OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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:
Hristian Kirtchev 2019-07-03 08:16:29 +00:00 committed by Pierre-Marie de Rodat
parent 336878fc11
commit 76b4158b8f
11 changed files with 979 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -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

298
gcc/ada/binde.adb
View File

@ -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;
-------------------------

260
gcc/ada/bindo-builders.adb
View File

@ -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;

8
gcc/ada/bindo-graphs.adb
View File

@ -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;
---------------------------

2
gcc/ada/bindo-graphs.ads
View File

@ -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.

26
gcc/ada/bindo-units.adb
View 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 --
---------------------------------

8
gcc/ada/bindo-units.ads
View File

@ -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

521
gcc/ada/butil.adb
View File

@ -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 --
----------------

53
gcc/ada/butil.ads
View File

@ -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;

9
gcc/ada/namet.adb
View File

@ -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 --
------------------

4
gcc/ada/namet.ads
View File

@ -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.