diff options
author | Bob Duff <duff@adacore.com> | 2018-01-11 08:53:27 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2018-01-11 08:53:27 +0000 |
commit | 8207dc2311d761ddff0de5d0a2e8a72dc4e94e78 (patch) | |
tree | 4d13a7bf55f96da66623be0b4fd18f03959f32f4 /gcc/ada/binde.adb | |
parent | 52c5090a4f940459ac3e38bcee0fd9f5f86a4eff (diff) | |
download | gcc-8207dc2311d761ddff0de5d0a2e8a72dc4e94e78.zip gcc-8207dc2311d761ddff0de5d0a2e8a72dc4e94e78.tar.gz gcc-8207dc2311d761ddff0de5d0a2e8a72dc4e94e78.tar.bz2 |
[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
Diffstat (limited to 'gcc/ada/binde.adb')
-rw-r--r-- | gcc/ada/binde.adb | 125 |
1 files changed, 94 insertions, 31 deletions
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 5a78bc8..ad863aa 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -33,6 +33,7 @@ with Output; use Output; with Table; with System.Case_Util; use System.Case_Util; +with System.HTable; with System.OS_Lib; package body Binde is @@ -1796,6 +1797,38 @@ package body Binde is 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, + 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 -- --------------- @@ -1848,6 +1881,8 @@ package body Binde is Last : Natural; begin + Cur_Line_Number := Cur_Line_Number + 1; + -- Skip to end of line while Cur <= S'Last @@ -1943,50 +1978,78 @@ package body Binde is while Cur <= S'Last loop declare Uname : constant Unit_Name_Type := Name_Find (Get_Line); - + Error : Boolean := False; begin if Uname = Empty_Name then null; -- silently skip blank lines - - 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 declare - Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); - + Dup : constant Line_Number := Name_Map.Get (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; + if Dup = No_Line_Number then + Name_Map.Set (Uname, Cur_Line_Number); - else - if Prev_Unit /= No_Unit_Id then + -- 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_Unit_Name (Units.Table (Prev_Unit).Uname); - Write_Str (" <-- "); - Write_Unit_Name (Units.Table (Cur_Unit).Uname); - Write_Eol; + Write_Line + ("""" & Get_Name_String (Uname) + & """: not present; ignored"); end if; - - Build_Link - (Before => Prev_Unit, - After => Cur_Unit, - R => Forced); 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 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; end loop; |