Rework errors handling, to have a more generic framework.

5 files changed, 239 insertions, 206 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;
diff --git a/src/errorout.ads b/src/errorout.ads
index 2c40d0047..bd6e08e50 100644
--- a/src/errorout.ads
+++ b/src/errorout.ads
@@ -16,8 +16,6 @@
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
 with Types; use Types;
-with Vhdl.Nodes;
-with Vhdl.Tokens;
 
 package Errorout is
    Compilation_Error: exception;
@@ -180,6 +178,31 @@ package Errorout is
    type Report_Origin is
      (Option, Library, Scan, Parse, Semantic, Elaboration);
 
+   --  Generic report message.
+   --  If ORIGIN is Option or Library, LOC must be No_Source_Coord and the
+   --  program name is displayed.
+   procedure Report_Msg (Id : Msgid_Type;
+                         Origin : Report_Origin;
+                         Loc : Source_Coord_Type;
+                         Msg : String;
+                         Args : Earg_Arr := No_Eargs);
+
+   --  Group several messages (for multi-lines messages).
+   --  Report_Start_Group must be called before the first Report_Msg call,
+   --  and Report_End_Group after the last one.
+   procedure Report_Start_Group;
+   procedure Report_End_Group;
+
+   --  Disp an error, prepended with program name.
+   --  This is used for errors before initialisation, such as bad option or
+   --  bad filename.
+   procedure Error_Msg_Option (Msg: String);
+
+   --  Warn about an option.
+   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String);
+
+   --  Low level part.
+
    type Error_Record is record
       Origin : Report_Origin;
       Id : Msgid_Type;
@@ -213,38 +236,27 @@ package Errorout is
 
    procedure Set_Report_Handler (Handler : Report_Msg_Handler);
 
-   --  Generic report message.
-   --  If ORIGIN is Option or Library, LOC must be No_Source_Coord and the
-   --  program name is displayed.
-   procedure Report_Msg (Id : Msgid_Type;
-                         Origin : Report_Origin;
-                         Loc : Source_Coord_Type;
-                         Msg : String;
-                         Args : Earg_Arr := No_Eargs);
-
-   --  Group several messages (for multi-lines messages).
-   --  Report_Start_Group must be called before the first Report_Msg call,
-   --  and Report_End_Group after the last one.
-   procedure Report_Start_Group;
-   procedure Report_End_Group;
-
-   --  Disp an error, prepended with program name.
-   --  This is used for errors before initialisation, such as bad option or
-   --  bad filename.
-   procedure Error_Msg_Option (Msg: String);
-
-   --  Warn about an option.
-   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String);
-
-   function Make_Earg_Vhdl_Node (V : Vhdl.Nodes.Iir) return Earg_Type;
-   function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) return Earg_Type;
-private
    type Earg_Kind is
      (Earg_None,
       Earg_Location, Earg_Id,
       Earg_Char, Earg_String8, Earg_Uns32, Earg_Int32,
       Earg_Vhdl_Node, Earg_Vhdl_Token);
 
+   subtype Earg_Lang_Kind is Earg_Kind range Earg_Vhdl_Node .. Earg_Kind'Last;
+
+   type Earg_Handler is
+     access procedure (Format : Character; Err : Error_Record; Val : Uns32);
+
+   procedure Register_Earg_Handler (Kind : Earg_Kind; Handler : Earg_Handler);
+
+   procedure Output_Identifier (Id : Name_Id);
+   procedure Output_Location (Err : Error_Record; Loc : Location_Type);
+   procedure Output_Message (S : String);
+
+   function Make_Earg_Vhdl_Node (V : Uns32) return Earg_Type;
+   function Make_Earg_Vhdl_Token (V : Uns32) return Earg_Type;
+private
+
    type Earg_Type (Kind : Earg_Kind := Earg_None) is record
       case Kind is
          when Earg_None =>
@@ -261,10 +273,8 @@ private
             Val_Uns32 : Uns32;
          when Earg_Int32 =>
             Val_Int32 : Int32;
-         when Earg_Vhdl_Node =>
-            Val_Vhdl_Node : Vhdl.Nodes.Iir;
-         when Earg_Vhdl_Token =>
-            Val_Vhdl_Tok : Vhdl.Tokens.Token_Type;
+         when Earg_Lang_Kind =>
+            Val_Lang : Uns32;
       end case;
    end record;
 
diff --git a/src/options.adb b/src/options.adb
index b8a7ec6ad..3db68ba25 100644
--- a/src/options.adb
+++ b/src/options.adb
@@ -26,6 +26,7 @@ with PSL.Dump_Tree;
 with Vhdl.Disp_Tree;
 with Vhdl.Scanner;
 with Vhdl.Parse;
+with Vhdl.Errors;
 with Vhdl.Back_End; use Vhdl.Back_End;
 with Flags; use Flags;
 with Files_Map;
@@ -37,6 +38,7 @@ package body Options is
       Libraries.Init_Paths;
       PSL.Nodes.Init;
       PSL.Dump_Tree.Dump_Hdl_Node := Vhdl.Disp_Tree.Disp_Tree_For_Psl'Access;
+      Vhdl.Errors.Initialize;
    end Initialize;
 
    function Option_Warning (Opt: String; Val : Boolean) return Option_State is
diff --git a/src/vhdl/vhdl-errors.adb b/src/vhdl/vhdl-errors.adb
index 6fcdacf67..ad57a735c 100644
--- a/src/vhdl/vhdl-errors.adb
+++ b/src/vhdl/vhdl-errors.adb
@@ -999,4 +999,60 @@ package body Vhdl.Errors is
       end case;
    end Get_Mode_Name;
 
+   function "+" (V : Iir) return Earg_Type is
+   begin
+      return Make_Earg_Vhdl_Node (Uns32 (V));
+   end "+";
+
+   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type is
+   begin
+      return Make_Earg_Vhdl_Token (Vhdl.Tokens.Token_Type'Pos (V));
+   end "+";
+
+   procedure Vhdl_Node_Handler
+     (Format : Character; Err : Error_Record; Val : Uns32)
+   is
+      N : constant Iir := Iir (Val);
+   begin
+      case Format is
+         when 'i' =>
+            Output_Identifier (Get_Identifier (N));
+         when 'l' =>
+            Output_Location (Err, Get_Location (N));
+         when 'n' =>
+            Output_Message (Disp_Node (N));
+         when others =>
+            raise Internal_Error;
+      end case;
+   end Vhdl_Node_Handler;
+
+   procedure Vhdl_Token_Handler
+     (Format : Character; Err : Error_Record; Val : Uns32)
+   is
+      pragma Unreferenced (Err);
+      use Vhdl.Tokens;
+      Tok : constant Token_Type := Token_Type'Val (Val);
+   begin
+      case Format is
+         when 't' =>
+            case Tok is
+               when Tok_Identifier =>
+                  Output_Message ("an identifier");
+               when Tok_Eof =>
+                  Output_Message ("end of file");
+               when others =>
+                  Output_Message ("'");
+                  Output_Message (Image (Tok));
+                  Output_Message ("'");
+            end case;
+         when others =>
+            raise Internal_Error;
+      end case;
+   end Vhdl_Token_Handler;
+
+   procedure Initialize is
+   begin
+      Register_Earg_Handler (Earg_Vhdl_Node, Vhdl_Node_Handler'Access);
+      Register_Earg_Handler (Earg_Vhdl_Token, Vhdl_Token_Handler'Access);
+   end Initialize;
 end Vhdl.Errors;
diff --git a/src/vhdl/vhdl-errors.ads b/src/vhdl/vhdl-errors.ads
index 97d38e7d6..98b8f1c9e 100644
--- a/src/vhdl/vhdl-errors.ads
+++ b/src/vhdl/vhdl-errors.ads
@@ -21,16 +21,17 @@ with Vhdl.Nodes; use Vhdl.Nodes;
 with Vhdl.Tokens;
 
 package Vhdl.Errors is
+   --  Register handlers so that errors can be handled.
+   procedure Initialize;
+
    --  This kind can't be handled.
    procedure Error_Kind (Msg: String; N : Iir);
    procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions);
    pragma No_Return (Error_Kind);
 
    --  Conversions
-   function "+" (V : Iir) return Earg_Type
-     renames Errorout.Make_Earg_Vhdl_Node;
-   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type
-     renames Errorout.Make_Earg_Vhdl_Token;
+   function "+" (V : Iir) return Earg_Type;
+   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type;
 
    --  Convert location.
    function "+" (L : Iir) return Location_Type;