Move errorout from vhdl/ to src/

1 files changed, 437 insertions, 0 deletions

diff --git a/src/errorout.adb b/src/errorout.adb
new file mode 100644
index 000000000..1b022391d
--- /dev/null
+++ b/src/errorout.adb
@@ -0,0 +1,437 @@
+--  Error message handling.
+--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
+--
+--  GHDL is free software; you can redistribute it and/or modify it under
+--  the terms of the GNU General Public License as published by the Free
+--  Software Foundation; either version 2, or (at your option) any later
+--  version.
+--
+--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
+--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+--  for more details.
+--
+--  You should have received a copy of the GNU General Public License
+--  along with GHDL; see the file COPYING.  If not, write to the Free
+--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+--  02111-1307, USA.
+
+with Logging; use Logging;
+with Vhdl.Scanner;
+with Name_Table;
+with Files_Map; use Files_Map;
+with Flags; use Flags;
+with PSL.Nodes;
+with Str_Table;
+
+with Vhdl.Errors; use Vhdl.Errors;
+
+package body Errorout is
+   procedure Error_Kind (Msg : String; N : PSL_Node) is
+   begin
+      Log (Msg);
+      Log (": cannot handle ");
+      Log_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N)));
+      raise Internal_Error;
+   end Error_Kind;
+
+   function Natural_Image (Val: Natural) return String
+   is
+      Str: constant String := Natural'Image (Val);
+   begin
+      return Str (Str'First + 1 .. Str'Last);
+   end Natural_Image;
+
+   function Get_Error_Col (E : Error_Record) return Natural
+   is
+      Line_Pos : Source_Ptr;
+   begin
+      Line_Pos := File_Line_To_Position (E.File, E.Line);
+      return Coord_To_Col (E.File, Line_Pos, E.Offset);
+   end Get_Error_Col;
+
+   Report_Handler : Report_Msg_Handler;
+
+   procedure Set_Report_Handler (Handler : Report_Msg_Handler) is
+   begin
+      Report_Handler := Handler;
+   end Set_Report_Handler;
+
+   --  Warnings.
+
+   Warnings_Control : Warnings_Setting := Default_Warnings;
+
+   procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean) is
+   begin
+      Warnings_Control (Id).Enabled := Enable;
+   end Enable_Warning;
+
+   function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean is
+   begin
+      return Warnings_Control (Id).Enabled;
+   end Is_Warning_Enabled;
+
+   function Warning_Image (Id : Msgid_Warnings) return String
+   is
+      Img : constant String := Msgid_Warnings'Image (Id);
+
+      --  Prefix to strip.
+      Prefix : constant String := "WARNID_";
+      pragma Assert (Img'Length > Prefix'Length);
+      pragma Assert (Img (1 .. Prefix'Length) = Prefix);
+      Res : String (1 .. Img'Last - Prefix'Length);
+      C : Character;
+   begin
+      --  Convert to lower cases, and '_' to '-'.
+      for I in Res'Range loop
+         C := Img (Prefix'Length + I);
+         case C is
+            when '_' =>
+               C := '-';
+            when 'A' .. 'Z' =>
+               C := Character'Val (Character'Pos (C) + 32);
+            when others =>
+               raise Internal_Error;
+         end case;
+         Res (I) := C;
+      end loop;
+
+      return Res;
+   end Warning_Image;
+
+   procedure Save_Warnings_Setting (Res : out Warnings_Setting) is
+   begin
+      Res := Warnings_Control;
+   end Save_Warnings_Setting;
+
+   procedure Disable_All_Warnings is
+   begin
+      Warnings_Control := (others => (Enabled => False, Error => False));
+   end Disable_All_Warnings;
+
+   procedure Restore_Warnings_Setting (Res : Warnings_Setting) is
+   begin
+      Warnings_Control := Res;
+   end Restore_Warnings_Setting;
+
+   --  Error arguments
+
+   function "+" (V : Location_Type) return Earg_Type is
+   begin
+      return (Kind => Earg_Location, Val_Loc => V);
+   end "+";
+
+   function "+" (V : Name_Id) return Earg_Type is
+   begin
+      return (Kind => Earg_Id, Val_Id => V);
+   end "+";
+
+   function "+" (V : Character) return Earg_Type is
+   begin
+      return (Kind => Earg_Char, Val_Char => V);
+   end "+";
+
+   function "+" (V : String8_Len_Type) return Earg_Type is
+   begin
+      return (Kind => Earg_String8, Val_Str8 => V);
+   end "+";
+
+   function "+" (L : PSL_Node) return Location_Type
+   is
+      use PSL.Nodes;
+   begin
+      if L = Null_Node then
+         return No_Location;
+      else
+         return PSL.Nodes.Get_Location (L);
+      end if;
+   end "+";
+
+   procedure Report_Msg (Id : Msgid_Type;
+                         Origin : Report_Origin;
+                         Loc : Location_Type;
+                         Msg : String;
+                         Args : Earg_Arr := No_Eargs;
+                         Cont : Boolean := False)
+   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;
+
+      File : Source_File_Entry;
+      Line : Natural;
+      New_Id : Msgid_Type;
+      Offset : Natural;
+      Loc_Length : Natural;
+      Line_Pos : Source_Ptr;
+      pragma Unreferenced (Line_Pos);
+   begin
+      --  Discard warnings that aren't enabled.
+      if Id in Msgid_Warnings and then not Is_Warning_Enabled (Id) then
+         return;
+      end if;
+
+      --  Reclassify warnings to errors if -Werror.
+      if Flags.Warn_Error
+        and then (Id = Msgid_Warning or Id in Msgid_Warnings)
+      then
+         New_Id := Msgid_Error;
+      else
+         New_Id := Id;
+      end if;
+      pragma Unreferenced (Id);
+
+      --  Limit the number of errors.
+      if not Cont and then New_Id = Msgid_Error then
+         Nbr_Errors := Nbr_Errors + 1;
+         if Nbr_Errors > Max_Nbr_Errors then
+            return;
+         end if;
+      end if;
+
+      --  Set error location.
+      File := No_Source_File_Entry;
+      Line := 0;
+      Offset := 0;
+      Loc_Length := 0;
+
+      case Origin is
+         when Option
+           | Library =>
+            pragma Assert (Loc = No_Location);
+            null;
+         when others =>
+            if Loc /= No_Location then
+               Location_To_Coord (Loc, File, Line_Pos, Line, Offset);
+            else
+               case Origin is
+                  when Option
+                    | Library =>
+                     raise Program_Error;
+                  when Elaboration =>
+                     null;
+                  when Scan =>
+                     File := Vhdl.Scanner.Get_Current_Source_File;
+                     Line := Vhdl.Scanner.Get_Current_Line;
+                     Offset := Vhdl.Scanner.Get_Current_Offset;
+                     Loc_Length := 1;
+                  when Parse =>
+                     File := Vhdl.Scanner.Get_Current_Source_File;
+                     Line := Vhdl.Scanner.Get_Current_Line;
+                     Offset := Vhdl.Scanner.Get_Token_Offset;
+                     Loc_Length := Vhdl.Scanner.Get_Current_Offset - Offset;
+                  when Semantic =>
+                     null;
+               end case;
+            end if;
+      end case;
+
+      Report_Handler.Error_Start
+        (Err => (Origin, New_Id, Cont, File, Line, Offset, Loc_Length));
+
+      --  Display message.
+      declare
+         First, N : Positive;
+         Argn : Integer;
+      begin
+         N := Msg'First;
+         First := N;
+         Argn := Args'First;
+         while N <= Msg'Last loop
+            if Msg (N) = '%' then
+               Report_Handler.Message (Msg (First .. N - 1));
+               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_Iir =>
+                              Id := Get_Identifier (Arg.Val_Iir);
+                           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.
+                              raise Internal_Error;
+                        end case;
+                        Report_Handler.Message ("'");
+                     end;
+                  when 't' =>
+                     --  A token
+                     declare
+                        use Vhdl.Tokens;
+                        Arg : Earg_Type renames Args (Argn);
+                        Tok : Token_Type;
+                     begin
+                        case Arg.Kind is
+                           when Earg_Token =>
+                              Tok := Arg.Val_Tok;
+                           when others =>
+                              --  Invalid conversion to character.
+                              raise Internal_Error;
+                        end case;
+                        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;
+                  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_Iir =>
+                              Arg_Loc := Get_Location (Arg.Val_Iir);
+                           when others =>
+                              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 = 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_Iir =>
+                              Report_Handler.Message (Disp_Node (Arg.Val_Iir));
+                           when others =>
+                              --  Invalid conversion to node.
+                              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.
+                              raise Internal_Error;
+                        end case;
+                        Report_Handler.Message ("""");
+                     end;
+                  when others =>
+                     --  Unknown format.
+                     raise Internal_Error;
+               end case;
+               Argn := Argn + 1;
+            end if;
+            N := N + 1;
+         end loop;
+         Report_Handler.Message (Msg (First .. N - 1));
+
+         --  Are all arguments displayed ?
+         pragma Assert (Argn > Args'Last);
+      end;
+
+      Report_Handler.Message_End.all;
+
+      if not Cont
+        and then New_Id = Msgid_Error
+        and then Nbr_Errors = Max_Nbr_Errors
+      then
+         --  Limit reached.  Emit a message.
+         Report_Handler.Error_Start (Err => (Option, Msgid_Error, False,
+                                             No_Source_File_Entry, 0, 0, 0));
+         Report_Handler.Message ("error limit reached");
+         Report_Handler.Message_End.all;
+      end if;
+   end Report_Msg;
+
+   procedure Error_Msg_Option_NR (Msg: String) is
+   begin
+      Report_Msg (Msgid_Error, Option, No_Location, Msg);
+   end Error_Msg_Option_NR;
+
+   procedure Error_Msg_Option (Msg: String) is
+   begin
+      Error_Msg_Option_NR (Msg);
+      raise Option_Error;
+   end Error_Msg_Option;
+
+   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String) is
+   begin
+      Report_Msg (Id, Option, No_Location, Msg);
+   end Warning_Msg_Option;
+
+   function Make_Earg_Vhdl_Node (V : Iir) return Earg_Type is
+   begin
+      return (Kind => Earg_Iir, Val_Iir => V);
+   end Make_Earg_Vhdl_Node;
+
+   function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type)
+                                 return Earg_Type is
+   begin
+      return (Kind => Earg_Token, Val_Tok => V);
+   end Make_Earg_Vhdl_Token;
+
+
+end Errorout;