Skip to content

R
riscv-gcc-1
Commit 8207dc23 by Bob Duff Committed by Pierre-Marie de Rodat
Options

[Ada] gnatbind -f switch gives an error for duplicates 

If the -felab-order.txt switch is given to gnatbind, and there are duplicate
unit names in elab-order.txt, an error will be given.

The following test should get errors:

this (spec) <-- that (body)
error: elab-order.txt:5: duplicate unit name "this (spec)" from line 1
error: elab-order.txt:7: duplicate unit name "that (body)" from line 3
gnatmake: *** bind failed.

Content of elab-order.txt (7 lines):

this%s

that%b

this (spec)

that%b

gnatmake -q -f -g -O0 -gnata that-main.adb -bargs -felab-order.txt

package body That is
end That;
package That is
   pragma Elaborate_Body;
end That;
with This, That;
procedure That.Main is
begin
   null;
end That.Main;
package body This is
end This;
package This is
   pragma Elaborate_Body;
end This;

2018-01-11  Bob Duff  <duff@adacore.com>

gcc/ada/

	* binde.adb (Force_Elab_Order): Give an error if there are duplicate
	unit names.

From-SVN: r256508
parent 52c5090a
Showing with 99 additions and 31 deletions
gcc/ada/ChangeLog
2018-01-11 Bob Duff <duff@adacore.com>
* binde.adb (Force_Elab_Order): Give an error if there are duplicate
unit names.
2018-01-11 Ed Schonberg <schonberg@adacore.com> 2018-01-11 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Freeze_Expr_Types): If an access value is the * sem_ch6.adb (Freeze_Expr_Types): If an access value is the
......
gcc/ada/binde.adb
...@@ -33,6 +33,7 @@ with Output; use Output; ...@@ -33,6 +33,7 @@ with Output; use Output;
with Table; with Table;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
with System.HTable;
with System.OS_Lib; with System.OS_Lib;
package body Binde is package body Binde is
...@@ -1796,6 +1797,38 @@ package body Binde is ...@@ -1796,6 +1797,38 @@ package body Binde is
function Read_File (Name : String) return String_Ptr; function Read_File (Name : String) return String_Ptr;
-- Read the entire contents of the named file -- 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,
No_Element => No_Line_Number,
Key => Unit_Name_Type,
Hash => Hash,
Equal => "=");
-- Name_Map contains an entry for each file name seen, mapped to the
-- line number where we saw it first. This is used to give an error for
-- duplicates.
----------
-- Hash --
----------
function Hash (N : Unit_Name_Type) return Header_Num is
-- Name_Ids are already widely dispersed; no need for any actual
-- hashing. Just subtract to make it zero based, and "mod" to
-- bring it in range.
begin
return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1);
end Hash;
--------------- ---------------
-- Read_File -- -- Read_File --
--------------- ---------------
...@@ -1848,6 +1881,8 @@ package body Binde is ...@@ -1848,6 +1881,8 @@ package body Binde is
Last : Natural; Last : Natural;
begin begin
Cur_Line_Number := Cur_Line_Number + 1;
-- Skip to end of line -- Skip to end of line
while Cur <= S'Last while Cur <= S'Last
...@@ -1943,50 +1978,78 @@ package body Binde is ...@@ -1943,50 +1978,78 @@ package body Binde is
while Cur <= S'Last loop while Cur <= S'Last loop
declare declare
Uname : constant Unit_Name_Type := Name_Find (Get_Line); Uname : constant Unit_Name_Type := Name_Find (Get_Line);
Error : Boolean := False;
begin begin
if Uname = Empty_Name then if Uname = Empty_Name then
null; -- silently skip blank lines null; -- silently skip blank lines
elsif Get_Name_Table_Int (Uname) = 0
or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
then
if Doing_New then
Write_Line
("""" & Get_Name_String (Uname)
& """: not present; ignored");
end if;
else else
declare declare
Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); Dup : constant Line_Number := Name_Map.Get (Uname);
begin begin
if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then if Dup = No_Line_Number then
if Doing_New then Name_Map.Set (Uname, Cur_Line_Number);
Write_Line
("""" & Get_Name_String (Uname) &
""": predefined unit ignored");
end if;
else -- We don't need to give the "not present" message in
if Prev_Unit /= No_Unit_Id then -- 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 if Doing_New then
Write_Unit_Name (Units.Table (Prev_Unit).Uname); Write_Line
Write_Str (" <-- "); ("""" & Get_Name_String (Uname)
Write_Unit_Name (Units.Table (Cur_Unit).Uname); & """: not present; ignored");
Write_Eol;
end if; end if;
Build_Link
(Before => Prev_Unit,
After => Cur_Unit,
R => Forced);
end if; end if;
Prev_Unit := Cur_Unit; 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 if;
end; 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;
Prev_Unit := Cur_Unit;
end if;
end;
end if;
end if; end if;
end; end;
end loop; end loop;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment