Rework errors handling, to have a more generic framework.

1 files changed, 134 insertions, 170 deletions

diff --git a/src/errorout.adb b/src/errorout.adb
index 79ed35dbf..8e9edf101 100644
--- a/src/errorout.adb
+++ b/src/errorout.adb
@@ -20,8 +20,6 @@ with Name_Table;
 with Files_Map; use Files_Map;
 with Str_Table;
 
-with Vhdl.Errors; use Vhdl.Errors;
-
 package body Errorout is
    --  Messages in a group.
    --  Set to 0 for individual messages,
@@ -158,21 +156,85 @@ package body Errorout is
       return Res;
    end "+";
 
-   procedure Report_Vhdl_Token (Tok : Vhdl.Tokens.Token_Type)
+   procedure Output_Identifier (Id : Name_Id) is
+   begin
+      Report_Handler.Message ("""");
+      Report_Handler.Message (Name_Table.Image (Id));
+      Report_Handler.Message ("""");
+   end Output_Identifier;
+
+   procedure Output_Character (C : Character) is
+   begin
+      Report_Handler.Message ("'");
+      Report_Handler.Message ((1 => C));
+      Report_Handler.Message ("'");
+   end Output_Character;
+
+   procedure Location_To_Position (Location : Location_Type;
+                                   File : out Source_File_Entry;
+                                   Line : out Natural;
+                                   Col : out Natural)
+   is
+      Name : Name_Id;
+      Line_Pos : Source_Ptr;
+      Offset : Natural;
+   begin
+      Location_To_Coord (Location, File, Line_Pos, Line, Offset);
+      Coord_To_Position (File, Line_Pos, Offset, Name, Col);
+   end Location_To_Position;
+
+   procedure Output_Location (Err : Error_Record; Loc : Location_Type)
+   is
+      Arg_File : Source_File_Entry;
+      Arg_Line : Natural;
+      Arg_Col : Natural;
+   begin
+      Location_To_Position (Loc, Arg_File, Arg_Line, Arg_Col);
+
+      --  Do not print the filename if in the same file as
+      --  the error location.
+      if Arg_File = Err.File then
+         Report_Handler.Message ("line ");
+      else
+         Report_Handler.Message (Name_Table.Image (Get_File_Name (Arg_File)));
+         Report_Handler.Message (":");
+      end if;
+      Report_Handler.Message (Natural_Image (Arg_Line));
+      Report_Handler.Message (":");
+      Report_Handler.Message (Natural_Image (Arg_Col));
+   end Output_Location;
+
+   procedure Output_Uns32 (V : Uns32)
    is
-      use Vhdl.Tokens;
-   begin
-      case Tok is
-         when Tok_Identifier =>
-            Report_Handler.Message ("an identifier");
-         when Tok_Eof =>
-            Report_Handler.Message ("end of file");
-         when others =>
-            Report_Handler.Message ("'");
-            Report_Handler.Message (Image (Tok));
-            Report_Handler.Message ("'");
-      end case;
-   end Report_Vhdl_Token;
+      S : constant String := Uns32'Image (V);
+   begin
+      Report_Handler.Message (S (2 .. S'Last));
+   end Output_Uns32;
+
+   procedure Output_String8 (Str : String8_Len_Type) is
+   begin
+      Report_Handler.Message ("""");
+      Report_Handler.Message (Str_Table.String_String8 (Str.Str, Str.Len));
+      Report_Handler.Message ("""");
+   end Output_String8;
+
+   procedure Output_Message (S : String) is
+   begin
+      Report_Handler.Message (S);
+   end Output_Message;
+
+   type Handlers_Array is array (Earg_Lang_Kind) of Earg_Handler;
+   Lang_Handlers : Handlers_Array := (others => null);
+
+   procedure Register_Earg_Handler
+     (Kind : Earg_Kind; Handler : Earg_Handler) is
+   begin
+      if Lang_Handlers (Kind) /= null then
+         --  Cannot change handler.
+         raise Internal_Error;
+      end if;
+      Lang_Handlers (Kind) := Handler;
+   end Register_Earg_Handler;
 
    procedure Report_Msg (Id : Msgid_Type;
                          Origin : Report_Origin;
@@ -180,20 +242,8 @@ package body Errorout is
                          Msg : String;
                          Args : Earg_Arr := No_Eargs)
    is
-      procedure Location_To_Position (Location : Location_Type;
-                                      File : out Source_File_Entry;
-                                      Line : out Natural;
-                                      Col : out Natural)
-      is
-         Name : Name_Id;
-         Line_Pos : Source_Ptr;
-         Offset : Natural;
-      begin
-         Location_To_Coord (Location, File, Line_Pos, Line, Offset);
-         Coord_To_Position (File, Line_Pos, Offset, Name, Col);
-      end Location_To_Position;
-
       New_Id : Msgid_Type;
+      Err : Error_Record;
    begin
       --  Discard warnings that aren't enabled.
       if Id in Msgid_Warnings and then not Is_Warning_Enabled (Id) then
@@ -228,9 +278,8 @@ package body Errorout is
          return;
       end if;
 
-      Report_Handler.Error_Start
-        (Err => (Origin, New_Id,
-                 Loc.File, Loc.Line, Loc.Offset, 0));
+      Err := (Origin, New_Id, Loc.File, Loc.Line, Loc.Offset, 0);
+      Report_Handler.Error_Start (Err);
 
       if In_Group > 0 then
          In_Group := In_Group + 1;
@@ -240,6 +289,7 @@ package body Errorout is
       declare
          First, N : Positive;
          Argn : Integer;
+         Format : Character;
       begin
          N := Msg'First;
          First := N;
@@ -250,145 +300,60 @@ package body Errorout is
                First := N + 2;
                pragma Assert (N < Msg'Last);
                N := N + 1;
-               case Msg (N) is
-                  when '%' =>
-                     Report_Handler.Message ("%");
-                     Argn := Argn - 1;
-                  when 'i' =>
-                     --  Identifier.
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                        Id : Name_Id;
-                     begin
-                        Report_Handler.Message ("""");
-                        case Arg.Kind is
-                           when Earg_Vhdl_Node =>
-                              Id := Vhdl.Nodes.Get_Identifier
-                                (Arg.Val_Vhdl_Node);
-                           when Earg_Id =>
-                              Id := Arg.Val_Id;
-                           when others =>
-                              --  Invalid conversion to identifier.
-                              raise Internal_Error;
-                        end case;
-                        Report_Handler.Message (Name_Table.Image (Id));
-                        Report_Handler.Message ("""");
-                     end;
-                  when 'c' =>
-                     --  Character
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                     begin
-                        Report_Handler.Message ("'");
-                        case Arg.Kind is
-                           when Earg_Char =>
-                              Report_Handler.Message ((1 => Arg.Val_Char));
-                           when others =>
-                              --  Invalid conversion to character.
+               Format := Msg (N);
+               if Format = '%' then
+                  --  Special case because there is no argument for the
+                  --  escape format.
+                  Report_Handler.Message ("%");
+               else
+                  declare
+                     Arg : Earg_Type renames Args (Argn);
+                  begin
+                     case Arg.Kind is
+                        when Earg_None =>
+                           raise Internal_Error;
+                        when Earg_Location =>
+                           if Format = 'l' then
+                              Output_Location (Err, Arg.Val_Loc);
+                           else
                               raise Internal_Error;
-                        end case;
-                        Report_Handler.Message ("'");
-                     end;
-                  when 't' =>
-                     --  A token
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                     begin
-                        case Arg.Kind is
-                           when Earg_Vhdl_Token =>
-                              Report_Vhdl_Token (Arg.Val_Vhdl_Tok);
-                           when others =>
-                              --  Invalid conversion to character.
+                           end if;
+                        when Earg_Id =>
+                           if Format = 'i' then
+                              Output_Identifier (Arg.Val_Id);
+                           else
                               raise Internal_Error;
-                        end case;
-                     end;
-                  when 'l' =>
-                     --  Location
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                        Arg_Loc : Location_Type;
-                        Arg_File : Source_File_Entry;
-                        Arg_Line : Natural;
-                        Arg_Col : Natural;
-                     begin
-                        case Arg.Kind is
-                           when Earg_Location =>
-                              Arg_Loc := Arg.Val_Loc;
-                           when Earg_Vhdl_Node =>
-                              Arg_Loc := Vhdl.Nodes.Get_Location
-                                (Arg.Val_Vhdl_Node);
-                           when others =>
+                           end if;
+                        when Earg_Char =>
+                           if Format = 'c' then
+                              Output_Character (Arg.Val_Char);
+                           else
                               raise Internal_Error;
-                        end case;
-                        Location_To_Position
-                          (Arg_Loc, Arg_File, Arg_Line, Arg_Col);
-
-                        --  Do not print the filename if in the same file as
-                        --  the error location.
-                        if Arg_File = Loc.File then
-                           Report_Handler.Message ("line ");
-                        else
-                           Report_Handler.Message
-                             (Name_Table.Image (Get_File_Name (Arg_File)));
-                           Report_Handler.Message (":");
-                        end if;
-                        Report_Handler.Message (Natural_Image (Arg_Line));
-                        Report_Handler.Message (":");
-                        Report_Handler.Message (Natural_Image (Arg_Col));
-                     end;
-                  when 'n' =>
-                     --  Node
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                     begin
-                        case Arg.Kind is
-                           when Earg_Vhdl_Node =>
-                              Report_Handler.Message
-                                (Disp_Node (Arg.Val_Vhdl_Node));
-                           when others =>
-                              --  Invalid conversion to node.
+                           end if;
+                        when Earg_String8 =>
+                           if Format = 's' then
+                              Output_String8 (Arg.Val_Str8);
+                           else
                               raise Internal_Error;
-                        end case;
-                     end;
-                  when 's' =>
-                     --  String
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                     begin
-                        Report_Handler.Message ("""");
-                        case Arg.Kind is
-                           when Earg_String8 =>
-                              Report_Handler.Message
-                                (Str_Table.String_String8
-                                   (Arg.Val_Str8.Str, Arg.Val_Str8.Len));
-                           when others =>
-                              --  Invalid conversion to character.
+                           end if;
+                        when Earg_Uns32 =>
+                           if Format = 'v' then
+                              Output_Uns32 (Arg.Val_Uns32);
+                           else
                               raise Internal_Error;
-                        end case;
-                        Report_Handler.Message ("""");
-                     end;
-                  when 'v' =>
-                     --  Numerical values
-                     declare
-                        Arg : Earg_Type renames Args (Argn);
-                     begin
-                        case Arg.Kind is
-                           when Earg_Uns32 =>
-                              declare
-                                 S : constant String :=
-                                   Uns32'Image (Arg.Val_Uns32);
-                              begin
-                                 Report_Handler.Message (S (2 .. S'Last));
-                              end;
-                           when others =>
+                           end if;
+                        when Earg_Int32 =>
+                           raise Internal_Error;
+                        when Earg_Lang_Kind =>
+                           if Lang_Handlers (Arg.Kind) = null then
                               raise Internal_Error;
-                        end case;
-                     end;
-                  when others =>
-                     --  Unknown format.
-                     raise Internal_Error;
-               end case;
-               Argn := Argn + 1;
+                           end if;
+                           Lang_Handlers (Arg.Kind)
+                             (Format, Err, Arg.Val_Lang);
+                     end case;
+                  end;
+                  Argn := Argn + 1;
+               end if;
             end if;
             N := N + 1;
          end loop;
@@ -425,14 +390,13 @@ package body Errorout is
       Report_Msg (Id, Option, No_Source_Coord, Msg);
    end Warning_Msg_Option;
 
-   function Make_Earg_Vhdl_Node (V : Vhdl.Nodes.Iir) return Earg_Type is
+   function Make_Earg_Vhdl_Node (V : Uns32) return Earg_Type is
    begin
-      return (Kind => Earg_Vhdl_Node, Val_Vhdl_Node => V);
+      return (Kind => Earg_Vhdl_Node, Val_Lang => V);
    end Make_Earg_Vhdl_Node;
 
-   function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type)
-                                 return Earg_Type is
+   function Make_Earg_Vhdl_Token (V : Uns32) return Earg_Type is
    begin
-      return (Kind => Earg_Vhdl_Token, Val_Vhdl_Tok => V);
+      return (Kind => Earg_Vhdl_Token, Val_Lang => V);
    end Make_Earg_Vhdl_Token;
 end Errorout;