[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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index fc30104ded284d665493d1f7e8702e00108def6a..ce0d63ce13da025fd1912abe97b842ffbbf259fb 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,8 @@
+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>
 
        * 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 5a78bc824994eb315ededbc1af9c70ef8b0e6967..ad863aabfb73030b5675cc4b8255012c73a5fa73 100644 (file)
--- 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;