comperr.adb (Compiler_Abort): New Finalize/Output_Messages interface for Errout

2007-04-20  Robert Dewar  <dewar@adacore.com>

	* comperr.adb (Compiler_Abort): New Finalize/Output_Messages interface
	for Errout

	* errout.adb: New Finalize/Compilation_Errors/Output_Messages
	implementation

	* errout.ads (Finalize): Changed interface
	(Output_Messages): New procedure
	(Compilation_Errors): New Interface

	* prepcomp.ads, prepcomp.adb (Parse_Preprocessing_Data_File): New
	Finalize/Output_Messages interface for Errout
	(Prepare_To_Preprocess): New Finalize/Output_Messages interface for
	Errout.

From-SVN: r125374

5 files changed, 364 insertions, 279 deletions

diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index e8a502c..9b89852 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -121,6 +121,7 @@ package body Comperr is
 
       if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
          Errout.Finalize;
+         Errout.Output_Messages;
 
          Set_Standard_Error;
          Write_Str ("compilation abandoned due to previous error");
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 6e05ec9..cfadbd8 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -40,7 +40,6 @@ with Fname;    use Fname;
 with Gnatvsn;  use Gnatvsn;
 with Hostparm; use Hostparm;
 with Lib;      use Lib;
-with Namet;    use Namet;
 with Opt;      use Opt;
 with Nlists;   use Nlists;
 with Output;   use Output;
@@ -61,6 +60,9 @@ package body Errout is
    --  error message procedures should be ignored (when parsing irrelevant
    --  text in sources being preprocessed).
 
+   Finalize_Called : Boolean := False;
+   --  Set True if the Finalize routine has been called
+
    Warn_On_Instance : Boolean;
    --  Flag set true for warning message to be posted on instance
 
@@ -138,8 +140,9 @@ package body Errout is
    --  location of the flag, which is provided for the internal call to
    --  Set_Msg_Insertion_Line_Number,
 
-   procedure Set_Msg_Insertion_Unit_Name;
-   --  Handle unit name insertion ($ insertion character)
+   procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
+   --  Handle unit name insertion ($ insertion character). Depending on Boolean
+   --  parameter Suffix, (spec) or (body) is appended after the unit name.
 
    procedure Set_Msg_Node (Node : Node_Id);
    --  Add the sequence of characters for the name associated with the
@@ -224,6 +227,19 @@ package body Errout is
       end if;
    end Change_Error_Text;
 
+   ------------------------
+   -- Compilation_Errors --
+   ------------------------
+
+   function Compilation_Errors return Boolean is
+   begin
+      if not Finalize_Called then
+         raise Program_Error;
+      else
+         return Erroutc.Compilation_Errors;
+      end if;
+   end Compilation_Errors;
+
    ---------------
    -- Error_Msg --
    ---------------
@@ -1163,9 +1179,252 @@ package body Errout is
    --------------
 
    procedure Finalize is
-      Cur      : Error_Msg_Id;
-      Nxt      : Error_Msg_Id;
-      E, F     : Error_Msg_Id;
+      Cur : Error_Msg_Id;
+      Nxt : Error_Msg_Id;
+      F   : Error_Msg_Id;
+
+   begin
+      --  Eliminate any duplicated error messages from the list. This is
+      --  done after the fact to avoid problems with Change_Error_Text.
+
+      Cur := First_Error_Msg;
+      while Cur /= No_Error_Msg loop
+         Nxt := Errors.Table (Cur).Next;
+
+         F := Nxt;
+         while F /= No_Error_Msg
+           and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
+         loop
+            Check_Duplicate_Message (Cur, F);
+            F := Errors.Table (F).Next;
+         end loop;
+
+         Cur := Nxt;
+      end loop;
+
+      --  Mark any messages suppressed by specific warnings as Deleted
+
+      Cur := First_Error_Msg;
+      while Cur /= No_Error_Msg loop
+         if not Errors.Table (Cur).Deleted
+           and then Warning_Specifically_Suppressed
+                     (Errors.Table (Cur).Sptr,
+                      Errors.Table (Cur).Text)
+         then
+            Errors.Table (Cur).Deleted := True;
+            Warnings_Detected := Warnings_Detected - 1;
+         end if;
+
+         Cur := Errors.Table (Cur).Next;
+      end loop;
+
+      --  Remaining processing should only be done once in the case where
+      --  Finalize has been called more than once.
+
+      if Finalize_Called then
+         return;
+      else
+         Finalize_Called := True;
+      end if;
+
+      --  Check consistency of specific warnings (may add warnings)
+
+      Validate_Specific_Warnings (Error_Msg'Access);
+   end Finalize;
+
+   ----------------
+   -- First_Node --
+   ----------------
+
+   function First_Node (C : Node_Id) return Node_Id is
+      L        : constant Source_Ptr        := Sloc (Original_Node (C));
+      Sfile    : constant Source_File_Index := Get_Source_File_Index (L);
+      Earliest : Node_Id;
+      Eloc     : Source_Ptr;
+      Discard  : Traverse_Result;
+
+      pragma Warnings (Off, Discard);
+
+      function Test_Earlier (N : Node_Id) return Traverse_Result;
+      --  Function applied to every node in the construct
+
+      function Search_Tree_First is new Traverse_Func (Test_Earlier);
+      --  Create traversal function
+
+      ------------------
+      -- Test_Earlier --
+      ------------------
+
+      function Test_Earlier (N : Node_Id) return Traverse_Result is
+         Loc : constant Source_Ptr := Sloc (Original_Node (N));
+
+      begin
+         --  Check for earlier. The tests for being in the same file ensures
+         --  against strange cases of foreign code somehow being present. We
+         --  don't want wild placement of messages if that happens, so it is
+         --  best to just ignore this situation.
+
+         if Loc < Eloc
+           and then Get_Source_File_Index (Loc) = Sfile
+         then
+            Earliest := Original_Node (N);
+            Eloc     := Loc;
+         end if;
+
+         return OK_Orig;
+      end Test_Earlier;
+
+   --  Start of processing for First_Node
+
+   begin
+      Earliest := Original_Node (C);
+      Eloc := Sloc (Earliest);
+      Discard := Search_Tree_First (Original_Node (C));
+      return Earliest;
+   end First_Node;
+
+   ----------------
+   -- First_Sloc --
+   ----------------
+
+   function First_Sloc (N : Node_Id) return Source_Ptr is
+      SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
+      SF : constant Source_Ptr        := Source_First (SI);
+      F  : Node_Id;
+      S  : Source_Ptr;
+
+   begin
+      F := First_Node (N);
+      S := Sloc (F);
+
+      --  The following circuit is a bit subtle. When we have parenthesized
+      --  expressions, then the Sloc will not record the location of the
+      --  paren, but we would like to post the flag on the paren. So what
+      --  we do is to crawl up the tree from the First_Node, adjusting the
+      --  Sloc value for any parentheses we know are present. Yes, we know
+      --  this circuit is not 100% reliable (e.g. because we don't record
+      --  all possible paren level values), but this is only for an error
+      --  message so it is good enough.
+
+      Node_Loop : loop
+         Paren_Loop : for J in 1 .. Paren_Count (F) loop
+
+            --  We don't look more than 12 characters behind the current
+            --  location, and in any case not past the front of the source.
+
+            Search_Loop : for K in 1 .. 12 loop
+               exit Search_Loop when S = SF;
+
+               if Source_Text (SI) (S - 1) = '(' then
+                  S := S - 1;
+                  exit Search_Loop;
+
+               elsif Source_Text (SI) (S - 1) <= ' ' then
+                  S := S - 1;
+
+               else
+                  exit Search_Loop;
+               end if;
+            end loop Search_Loop;
+         end loop Paren_Loop;
+
+         exit Node_Loop when F = N;
+         F := Parent (F);
+         exit Node_Loop when Nkind (F) not in N_Subexpr;
+      end loop Node_Loop;
+
+      return S;
+   end First_Sloc;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Errors.Init;
+      First_Error_Msg := No_Error_Msg;
+      Last_Error_Msg := No_Error_Msg;
+      Serious_Errors_Detected := 0;
+      Total_Errors_Detected := 0;
+      Warnings_Detected := 0;
+      Cur_Msg := No_Error_Msg;
+      List_Pragmas.Init;
+
+      --  Initialize warnings table, if all warnings are suppressed, supply
+      --  an initial dummy entry covering all possible source locations.
+
+      Warnings.Init;
+      Specific_Warnings.Init;
+
+      if Warning_Mode = Suppress then
+         Warnings.Increment_Last;
+         Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
+         Warnings.Table (Warnings.Last).Stop  := Source_Ptr'Last;
+      end if;
+   end Initialize;
+
+   -----------------
+   -- No_Warnings --
+   -----------------
+
+   function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
+   begin
+      if Error_Posted (N) then
+         return True;
+
+      elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
+         return True;
+
+      elsif Is_Entity_Name (N)
+        and then Present (Entity (N))
+        and then Warnings_Off (Entity (N))
+      then
+         return True;
+
+      else
+         return False;
+      end if;
+   end No_Warnings;
+
+   -------------
+   -- OK_Node --
+   -------------
+
+   function OK_Node (N : Node_Id) return Boolean is
+      K : constant Node_Kind := Nkind (N);
+
+   begin
+      if Error_Posted (N) then
+         return False;
+
+      elsif K in N_Has_Etype
+        and then Present (Etype (N))
+        and then Error_Posted (Etype (N))
+      then
+         return False;
+
+      elsif (K in N_Op
+              or else K = N_Attribute_Reference
+              or else K = N_Character_Literal
+              or else K = N_Expanded_Name
+              or else K = N_Identifier
+              or else K = N_Operator_Symbol)
+        and then Present (Entity (N))
+        and then Error_Posted (Entity (N))
+      then
+         return False;
+      else
+         return True;
+      end if;
+   end OK_Node;
+
+   ---------------------
+   -- Output_Messages --
+   ---------------------
+
+   procedure Output_Messages is
+      E        : Error_Msg_Id;
       Err_Flag : Boolean;
 
       procedure Write_Error_Summary;
@@ -1297,56 +1556,25 @@ package body Errout is
          end if;
       end Write_Max_Errors;
 
-   --  Start of processing for Finalize
+   --  Start of processing for Output_Messages
 
    begin
+      --  Error if Finalize has not been called
+
+      if not Finalize_Called then
+         raise Program_Error;
+      end if;
+
       --  Reset current error source file if the main unit has a pragma
       --  Source_Reference. This ensures outputting the proper name of
       --  the source file in this situation.
 
-      if Main_Source_File = No_Source_File or else
-        Num_SRef_Pragmas (Main_Source_File) /= 0
+      if Main_Source_File = No_Source_File
+        or else Num_SRef_Pragmas (Main_Source_File) /= 0
       then
          Current_Error_Source_File := No_Source_File;
       end if;
 
-      --  Eliminate any duplicated error messages from the list. This is
-      --  done after the fact to avoid problems with Change_Error_Text.
-
-      Cur := First_Error_Msg;
-      while Cur /= No_Error_Msg loop
-         Nxt := Errors.Table (Cur).Next;
-
-         F := Nxt;
-         while F /= No_Error_Msg
-           and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
-         loop
-            Check_Duplicate_Message (Cur, F);
-            F := Errors.Table (F).Next;
-         end loop;
-
-         Cur := Nxt;
-      end loop;
-
-      --  Mark any messages suppressed by specific warnings as Deleted
-
-      Cur := First_Error_Msg;
-      while Cur /= No_Error_Msg loop
-         if Warning_Specifically_Suppressed
-             (Errors.Table (Cur).Sptr,
-              Errors.Table (Cur).Text)
-         then
-            Errors.Table (Cur).Deleted := True;
-            Warnings_Detected := Warnings_Detected - 1;
-         end if;
-
-         Cur := Errors.Table (Cur).Next;
-      end loop;
-
-      --  Check consistency of specific warnings (may add warnings)
-
-      Validate_Specific_Warnings (Error_Msg'Access);
-
       --  Brief Error mode
 
       if Brief_Output or (not Full_List and not Verbose_Mode) then
@@ -1544,194 +1772,7 @@ package body Errout is
          Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
          Warnings_Detected := 0;
       end if;
-   end Finalize;
-
-   ----------------
-   -- First_Node --
-   ----------------
-
-   function First_Node (C : Node_Id) return Node_Id is
-      L        : constant Source_Ptr        := Sloc (Original_Node (C));
-      Sfile    : constant Source_File_Index := Get_Source_File_Index (L);
-      Earliest : Node_Id;
-      Eloc     : Source_Ptr;
-      Discard  : Traverse_Result;
-
-      pragma Warnings (Off, Discard);
-
-      function Test_Earlier (N : Node_Id) return Traverse_Result;
-      --  Function applied to every node in the construct
-
-      function Search_Tree_First is new Traverse_Func (Test_Earlier);
-      --  Create traversal function
-
-      ------------------
-      -- Test_Earlier --
-      ------------------
-
-      function Test_Earlier (N : Node_Id) return Traverse_Result is
-         Loc : constant Source_Ptr := Sloc (Original_Node (N));
-
-      begin
-         --  Check for earlier. The tests for being in the same file ensures
-         --  against strange cases of foreign code somehow being present. We
-         --  don't want wild placement of messages if that happens, so it is
-         --  best to just ignore this situation.
-
-         if Loc < Eloc
-           and then Get_Source_File_Index (Loc) = Sfile
-         then
-            Earliest := Original_Node (N);
-            Eloc     := Loc;
-         end if;
-
-         return OK_Orig;
-      end Test_Earlier;
-
-   --  Start of processing for First_Node
-
-   begin
-      Earliest := Original_Node (C);
-      Eloc := Sloc (Earliest);
-      Discard := Search_Tree_First (Original_Node (C));
-      return Earliest;
-   end First_Node;
-
-   ----------------
-   -- First_Sloc --
-   ----------------
-
-   function First_Sloc (N : Node_Id) return Source_Ptr is
-      SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
-      SF : constant Source_Ptr        := Source_First (SI);
-      F  : Node_Id;
-      S  : Source_Ptr;
-
-   begin
-      F := First_Node (N);
-      S := Sloc (F);
-
-      --  The following circuit is a bit subtle. When we have parenthesized
-      --  expressions, then the Sloc will not record the location of the
-      --  paren, but we would like to post the flag on the paren. So what
-      --  we do is to crawl up the tree from the First_Node, adjusting the
-      --  Sloc value for any parentheses we know are present. Yes, we know
-      --  this circuit is not 100% reliable (e.g. because we don't record
-      --  all possible paren level valoues), but this is only for an error
-      --  message so it is good enough.
-
-      Node_Loop : loop
-         Paren_Loop : for J in 1 .. Paren_Count (F) loop
-
-            --  We don't look more than 12 characters behind the current
-            --  location, and in any case not past the front of the source.
-
-            Search_Loop : for K in 1 .. 12 loop
-               exit Search_Loop when S = SF;
-
-               if Source_Text (SI) (S - 1) = '(' then
-                  S := S - 1;
-                  exit Search_Loop;
-
-               elsif Source_Text (SI) (S - 1) <= ' ' then
-                  S := S - 1;
-
-               else
-                  exit Search_Loop;
-               end if;
-            end loop Search_Loop;
-         end loop Paren_Loop;
-
-         exit Node_Loop when F = N;
-         F := Parent (F);
-         exit Node_Loop when Nkind (F) not in N_Subexpr;
-      end loop Node_Loop;
-
-      return S;
-   end First_Sloc;
-
-   ----------------
-   -- Initialize --
-   ----------------
-
-   procedure Initialize is
-   begin
-      Errors.Init;
-      First_Error_Msg := No_Error_Msg;
-      Last_Error_Msg := No_Error_Msg;
-      Serious_Errors_Detected := 0;
-      Total_Errors_Detected := 0;
-      Warnings_Detected := 0;
-      Cur_Msg := No_Error_Msg;
-      List_Pragmas.Init;
-
-      --  Initialize warnings table, if all warnings are suppressed, supply
-      --  an initial dummy entry covering all possible source locations.
-
-      Warnings.Init;
-      Specific_Warnings.Init;
-
-      if Warning_Mode = Suppress then
-         Warnings.Increment_Last;
-         Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
-         Warnings.Table (Warnings.Last).Stop  := Source_Ptr'Last;
-      end if;
-   end Initialize;
-
-   -----------------
-   -- No_Warnings --
-   -----------------
-
-   function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
-   begin
-      if Error_Posted (N) then
-         return True;
-
-      elsif Nkind (N) in N_Entity and then Warnings_Off (N) then
-         return True;
-
-      elsif Is_Entity_Name (N)
-        and then Present (Entity (N))
-        and then Warnings_Off (Entity (N))
-      then
-         return True;
-
-      else
-         return False;
-      end if;
-   end No_Warnings;
-
-   -------------
-   -- OK_Node --
-   -------------
-
-   function OK_Node (N : Node_Id) return Boolean is
-      K : constant Node_Kind := Nkind (N);
-
-   begin
-      if Error_Posted (N) then
-         return False;
-
-      elsif K in N_Has_Etype
-        and then Present (Etype (N))
-        and then Error_Posted (Etype (N))
-      then
-         return False;
-
-      elsif (K in N_Op
-              or else K = N_Attribute_Reference
-              or else K = N_Character_Literal
-              or else K = N_Expanded_Name
-              or else K = N_Identifier
-              or else K = N_Operator_Symbol)
-        and then Present (Entity (N))
-        and then Error_Posted (Entity (N))
-      then
-         return False;
-      else
-         return True;
-      end if;
-   end OK_Node;
+   end Output_Messages;
 
    ------------------------
    -- Output_Source_Line --
@@ -2277,17 +2318,17 @@ package body Errout is
    -- Set_Msg_Insertion_Unit_Name --
    ---------------------------------
 
-   procedure Set_Msg_Insertion_Unit_Name is
+   procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
    begin
-      if Error_Msg_Unit_1 = No_Name then
+      if Error_Msg_Unit_1 = No_Unit_Name then
          null;
 
-      elsif Error_Msg_Unit_1 = Error_Name then
+      elsif Error_Msg_Unit_1 = Error_Unit_Name then
          Set_Msg_Blank;
          Set_Msg_Str ("<error>");
 
       else
-         Get_Unit_Name_String (Error_Msg_Unit_1);
+         Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
          Set_Msg_Blank;
          Set_Msg_Quote;
          Set_Msg_Name_Buffer;
@@ -2457,8 +2498,8 @@ package body Errout is
    ------------------
 
    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
-      C : Character;         -- Current character
-      P : Natural;           -- Current index;
+      C : Character;   -- Current character
+      P : Natural;     -- Current index;
 
    begin
       Manual_Quote_Mode := False;
@@ -2471,14 +2512,25 @@ package body Errout is
          C := Text (P);
          P := P + 1;
 
-         --  Check for insertion character
+         --  Check for insertion character or sequence
 
          case C is
             when '%' =>
-               Set_Msg_Insertion_Name;
+               if P <= Text'Last and then Text (P) = '%' then
+                  P := P + 1;
+                  Set_Msg_Insertion_Name_Literal;
+               else
+                  Set_Msg_Insertion_Name;
+               end if;
 
             when '$' =>
-               Set_Msg_Insertion_Unit_Name;
+               if P <= Text'Last and then Text (P) = '$' then
+                  P := P + 1;
+                  Set_Msg_Insertion_Unit_Name (Suffix => False);
+
+               else
+                  Set_Msg_Insertion_Unit_Name;
+               end if;
 
             when '{' =>
                Set_Msg_Insertion_File_Name;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index f4644c2..9992cb4 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,9 +31,10 @@
 
 with Err_Vars;
 with Erroutc;
+with Namet;    use Namet;
 with Table;
-with Types; use Types;
-with Uintp; use Uintp;
+with Types;    use Types;
+with Uintp;    use Uintp;
 
 with System;
 
@@ -147,7 +148,15 @@ package Errout is
    --      message, similarly replaced by the names which are specified by the
    --      Name_Id values stored in Error_Msg_Name_2 and Error_Msg_Name_3. The
    --      names are decoded and cased according to the current identifier
-   --      casing mode.
+   --      casing mode. Note: if a unit name ending with %b or %s is passed
+   --      for this kind of insertion, this suffix is simply stripped. Use a
+   --      unit name insertion ($) to process the suffix.
+
+   --    Insertion character %% (Double percent: insert literal name)
+   --      The character sequence %% acts as described above for %, except
+   --      that the name is simply obtained with Get_Name_String and is not
+   --      decoded or cased, it is inserted literally from the names table.
+   --      A trailing %b or %s is not treated specially.
 
    --    Insertion character $ (Dollar: insert unit name from Names table)
    --      The character $ is treated similarly to %, except that the name is
@@ -157,11 +166,13 @@ package Errout is
    --      strings. If this postfix is not required, use the normal %
    --      insertion for the unit name.
 
-   --    Insertion character { (Left brace: insert literally from names table)
-   --      The character { is treated similarly to %, except that the name is
-   --      output literally as stored in the names table without adjusting the
-   --      casing. This can be used for file names and in other situations
-   --      where the name string is to be output unchanged.
+   --    Insertion character { (Left brace: insert file name from names table)
+   --      The character { is treated similarly to %, except that the input
+   --      value is a File_Name_Type value stored in Error_Msg_File_1 or
+   --      Error_Msg_File_2 or Error_Msg_File_3. The value is output literally,
+   --      enclosed in quotes as for %, but the case is not modified, the
+   --      insertion is the exact string stored in the names table without
+   --      adjusting the casing.
 
    --    Insertion character * (Asterisk, insert reserved word name)
    --      The insertion character * is treated exactly like % except that the
@@ -384,9 +395,14 @@ package Errout is
    Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3;
    --  Name_Id values for % insertion characters in message
 
-   Error_Msg_Unit_1 : Name_Id renames Err_Vars.Error_Msg_Unit_1;
-   Error_Msg_Unit_2 : Name_Id renames Err_Vars.Error_Msg_Unit_2;
-   --  Name_Id values for $ insertion characters in message
+   Error_Msg_File_1 : File_Name_Type renames Err_Vars.Error_Msg_File_1;
+   Error_Msg_File_2 : File_Name_Type renames Err_Vars.Error_Msg_File_2;
+   Error_Msg_File_3 : File_Name_Type renames Err_Vars.Error_Msg_File_3;
+   --  File_Name_Type values for { insertion characters in message
+
+   Error_Msg_Unit_1 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_1;
+   Error_Msg_Unit_2 : Unit_Name_Type renames Err_Vars.Error_Msg_Unit_2;
+   --  Unit_Name_Type values for $ insertion characters in message
 
    Error_Msg_Node_1 : Node_Id renames Err_Vars.Error_Msg_Node_1;
    Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2;
@@ -545,8 +561,21 @@ package Errout is
    --  source file before using any of the other routines in the package.
 
    procedure Finalize;
-   --  Finalize processing of error messages for one file and output message
-   --  indicating the number of detected errors.
+   --  Finalize processing of error message list. Includes processing for
+   --  duplicated error messages, and other similar final adjustment of the
+   --  list of error messages. Note that this procedure must be called before
+   --  calling Compilation_Errors to determine if there were any errors. It
+   --  is perfectly fine to call Finalize more than once. Indeed this can
+   --  make good sense. For example, do some processing that may generate
+   --  messages. Call Finalize to eliminate duplicates and remove deleted
+   --  warnings. Test for compilation errors using Compilation_Errors, then
+   --  generate some more errors/warnings, call Finalize again to make sure
+   --  that all duplicates in these new messages are dealt with, then finally
+   --  call Output_Messages to output the final list of messages.
+
+   procedure Output_Messages;
+   --  Output list of messages, including messages giving number of detected
+   --  errors and warnings.
 
    procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
    --  Output a message at specified location. Can be called from the parser
@@ -687,10 +716,10 @@ package Errout is
    --  the pragma. Err is set to True on return to report the error of no
    --  matching Warnings Off pragma preceding this one.
 
-   function Compilation_Errors return Boolean
-     renames Erroutc.Compilation_Errors;
+   function Compilation_Errors return Boolean;
    --  Returns true if errors have been detected, or warnings in -gnatwe
-   --  (treat warnings as errors) mode.
+   --  (treat warnings as errors) mode. Note that it is mandatory to call
+   --  Finalize before calling this routine.
 
    procedure Error_Msg_CRT (Feature : String; N : Node_Id);
    --  Posts a non-fatal message on node N saying that the feature identified
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index 763654c..4a590e4 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2003-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 2003-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -27,7 +27,6 @@
 with Ada.Unchecked_Deallocation;
 
 with Errout;   use Errout;
-with Namet;    use Namet;
 with Lib.Writ; use Lib.Writ;
 with Opt;      use Opt;
 with Osint;    use Osint;
@@ -37,6 +36,7 @@ with Scn;      use Scn;
 with Sinput.L; use Sinput.L;
 with Stringt;  use Stringt;
 with Table;
+with Types;    use Types;
 
 package body Prepcomp is
 
@@ -69,20 +69,20 @@ package body Prepcomp is
 
    type Preproc_Data is record
       Mapping      : Symbol_Table.Instance;
-      File_Name    : Name_Id   := No_Name;
-      Deffile      : String_Id := No_String;
-      Undef_False  : Boolean   := False;
-      Always_Blank : Boolean   := False;
-      Comments     : Boolean   := False;
-      List_Symbols : Boolean   := False;
-      Processed    : Boolean   := False;
+      File_Name    : File_Name_Type := No_File;
+      Deffile      : String_Id      := No_String;
+      Undef_False  : Boolean        := False;
+      Always_Blank : Boolean        := False;
+      Comments     : Boolean        := False;
+      List_Symbols : Boolean        := False;
+      Processed    : Boolean        := False;
    end record;
    --  Structure to keep the preprocessing data for a file name or for the
    --  default (when Name_Id = No_Name).
 
    No_Preproc_Data : constant Preproc_Data :=
      (Mapping      => No_Mapping,
-      File_Name    => No_Name,
+      File_Name    => No_File,
       Deffile      => No_String,
       Undef_False  => False,
       Always_Blank => False,
@@ -295,7 +295,7 @@ package body Prepcomp is
                   if Current_Data.File_Name =
                        Preproc_Data_Table.Table (Index).File_Name
                   then
-                     Error_Msg_Name_1 := Current_Data.File_Name;
+                     Error_Msg_File_1 := Current_Data.File_Name;
                      Error_Msg
                        ("multiple preprocessing data for{", Token_Ptr);
                      OK := False;
@@ -544,7 +544,7 @@ package body Prepcomp is
 
          --  Record Current_Data
 
-         if Current_Data.File_Name = No_Name then
+         if Current_Data.File_Name = No_File then
             Default_Data := Current_Data;
 
          else
@@ -561,6 +561,7 @@ package body Prepcomp is
 
       if Total_Errors_Detected > T then
          Errout.Finalize;
+         Errout.Output_Messages;
          Fail ("errors found in preprocessing data file """,
                Get_Name_String (N),
                """");
@@ -648,10 +649,11 @@ package body Prepcomp is
          String_To_Name_Buffer (Current_Data.Deffile);
 
          declare
-            N : constant Name_Id := Name_Find;
-            Deffile : constant Source_File_Index :=  Load_Definition_File (N);
-            Add_Deffile : Boolean := True;
-            T : constant Nat := Total_Errors_Detected;
+            N           : constant File_Name_Type    := Name_Find;
+            Deffile     : constant Source_File_Index :=
+                            Load_Definition_File (N);
+            Add_Deffile : Boolean                    := True;
+            T           : constant Nat               := Total_Errors_Detected;
 
          begin
             if Deffile = No_Source_File then
@@ -686,6 +688,7 @@ package body Prepcomp is
 
             if T /= Total_Errors_Detected then
                Errout.Finalize;
+               Errout.Output_Messages;
                Fail ("errors found in definition file """,
                      Get_Name_String (N),
                      """");
diff --git a/gcc/ada/prepcomp.ads b/gcc/ada/prepcomp.ads
index 9c74df8..c9b6b38 100644
--- a/gcc/ada/prepcomp.ads
+++ b/gcc/ada/prepcomp.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2002-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 2002-2007, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -26,7 +26,7 @@
 
 --  This package stores all preprocessing data for the compiler
 
-with Types; use Types;
+with Namet; use Namet;
 
 package Prepcomp is