From 8207dc2311d761ddff0de5d0a2e8a72dc4e94e78 Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 11 Jan 2018 08:53:27 +0000 Subject: [PATCH] [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 gcc/ada/ * binde.adb (Force_Elab_Order): Give an error if there are duplicate unit names. From-SVN: r256508 --- gcc/ada/ChangeLog | 5 ++ gcc/ada/binde.adb | 125 ++++++++++++++++++++++++++++++++++------------ 2 files changed, 99 insertions(+), 31 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fc30104ded2..ce0d63ce13d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2018-01-11 Bob Duff + + * binde.adb (Force_Elab_Order): Give an error if there are duplicate + unit names. + 2018-01-11 Ed Schonberg * sem_ch6.adb (Freeze_Expr_Types): If an access value is the diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 5a78bc82499..ad863aabfb7 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; -- 2.30.2