diff options
Diffstat (limited to 'src/vhdl/errorout.adb')
-rw-r--r-- | src/vhdl/errorout.adb | 404 |
1 files changed, 108 insertions, 296 deletions
diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb index a86eb890b..64b0d8d0b 100644 --- a/src/vhdl/errorout.adb +++ b/src/vhdl/errorout.adb @@ -17,7 +17,6 @@ -- 02111-1307, USA. with Ada.Text_IO; -with GNAT.OS_Lib; with Scanner; with Name_Table; with Iirs_Utils; use Iirs_Utils; @@ -29,76 +28,59 @@ with PSL.Nodes; with Str_Table; package body Errorout is - -- Name of the program, used to report error message. - Program_Name : String_Acc := null; - - -- Terminal. + procedure Error_Kind (Msg : String; An_Iir : Iir) + is + use Ada.Text_IO; + begin + Put_Line + (Standard_Error, + Msg & ": cannot handle " & Iir_Kind'Image (Get_Kind (An_Iir)) + & " (" & Disp_Location (An_Iir) & ')'); + raise Internal_Error; + end Error_Kind; - -- Set Flag_Color_Diagnostics to On or Off if is was Auto. - procedure Detect_Terminal + procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is - -- Import isatty. - function isatty (Fd : Integer) return Integer; - pragma Import (C, isatty); + use Ada.Text_IO; + begin + Put_Line + (Standard_Error, + Msg & ": cannot handle " & Iir_Predefined_Functions'Image (Def)); + raise Internal_Error; + end Error_Kind; - -- Awful way to detect if the host is Windows. Should be replaced by - -- a host-specific package. - Is_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; + procedure Error_Kind (Msg : String; N : PSL_Node) + is + use Ada.Text_IO; begin - if Flag_Color_Diagnostics = Auto then - if Is_Windows then - -- Off by default on Windows, as the consoles may not support - -- ANSI control sequences. Should be replaced by calls to the - -- Win32 API. - Flag_Color_Diagnostics := Off; - else - -- On Linux/Unix/Mac OS X: use color only when the output is to a - -- tty. - if isatty (2) /= 0 then - Flag_Color_Diagnostics := On; - else - Flag_Color_Diagnostics := Off; - end if; - end if; - end if; - end Detect_Terminal; + Put (Standard_Error, Msg); + Put (Standard_Error, ": cannot handle "); + Put_Line (Standard_Error, + PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N))); + raise Internal_Error; + end Error_Kind; - -- Color to be used for various part of messages. - type Color_Type is (Color_Locus, - Color_Note, Color_Warning, Color_Error, Color_Fatal, - Color_Message, - Color_None); + 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; - -- Switch to COLOR. - procedure Set_Color (Color : Color_Type) + function Get_Error_Col (E : Error_Record) return Natural is - procedure Put (S : String) - is - use Ada.Text_IO; - begin - Put (Standard_Error, S); - end Put; + Line_Pos : Source_Ptr; begin - if Flag_Color_Diagnostics = Off then - return; - end if; + Line_Pos := Line_To_Position (E.File, E.Line); + return Coord_To_Col (E.File, Line_Pos, E.Offset); + end Get_Error_Col; - -- Use ANSI sequences. - -- They are also documented on msdn in 'Console Virtual Terminal - -- sequences'. - - Put (ASCII.ESC & '['); - case Color is - when Color_Locus => Put ("1"); -- Bold - when Color_Note => Put ("1;36"); -- Bold, cyan - when Color_Warning => Put ("1;35"); -- Bold, magenta - when Color_Error => Put ("1;31"); -- Bold, red - when Color_Fatal => Put ("1;33"); -- Bold, yellow - when Color_Message => Put ("0;1"); -- Normal, bold - when Color_None => Put ("0"); -- Normal - end case; - Put ("m"); - end Set_Color; + Report_Handler : Report_Msg_Handler; + + procedure Set_Report_Handler (Handler : Report_Msg_Handler) is + begin + Report_Handler := Handler; + end Set_Report_Handler; -- Warnings. @@ -211,90 +193,6 @@ package body Errorout is end if; end "+"; - Msg_Len : Natural; - - procedure Put (Str : String) - is - use Ada.Text_IO; - begin - Msg_Len := Msg_Len + Str'Length; - Put (Standard_Error, Str); - end Put; - - procedure Put (C : Character) - is - use Ada.Text_IO; - begin - Msg_Len := Msg_Len + 1; - Put (Standard_Error, C); - end Put; - - procedure Put_Line (Str : String := "") - is - use Ada.Text_IO; - begin - Put_Line (Standard_Error, Str); - Msg_Len := 0; - end Put_Line; - - procedure Disp_Natural (Val: Natural) - is - Str: constant String := Natural'Image (Val); - begin - Put (Str (Str'First + 1 .. Str'Last)); - end Disp_Natural; - - procedure Error_Kind (Msg : String; An_Iir : Iir) is - begin - Put_Line (Msg & ": cannot handle " - & Iir_Kind'Image (Get_Kind (An_Iir)) - & " (" & Disp_Location (An_Iir) & ')'); - raise Internal_Error; - end Error_Kind; - - procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is - begin - Put_Line (Msg & ": cannot handle " - & Iir_Predefined_Functions'Image (Def)); - raise Internal_Error; - end Error_Kind; - - procedure Error_Kind (Msg : String; N : PSL_Node) is - begin - Put (Msg); - Put (": cannot handle "); - Put_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N))); - raise Internal_Error; - end Error_Kind; - - procedure Disp_Location - (File: Name_Id; Line: Natural; Col: Natural) is - begin - if File = Null_Identifier then - Put ("??"); - else - Put (Name_Table.Image (File)); - end if; - Put (':'); - Disp_Natural (Line); - Put (':'); - Disp_Natural (Col); - Put (':'); - end Disp_Location; - - procedure Set_Program_Name (Name : String) is - begin - Program_Name := new String'(Name); - end Set_Program_Name; - - procedure Disp_Program_Name is - begin - if Program_Name /= null then - Put (Program_Name.all); - Put (':'); - end if; - end Disp_Program_Name; - procedure Report_Msg (Id : Msgid_Type; Origin : Report_Origin; Loc : Location_Type; @@ -302,7 +200,6 @@ package body Errorout is Args : Earg_Arr := No_Eargs; Cont : Boolean := False) is - pragma Unreferenced (Cont); procedure Location_To_Position (Location : Location_Type; File : out Source_File_Entry; Line : out Natural; @@ -318,116 +215,45 @@ package body Errorout is File : Source_File_Entry; Line : Natural; - Col : Natural; - Progname : Boolean; + Offset : Natural; + Line_Pos : Source_Ptr; + pragma Unreferenced (Line_Pos); begin - -- By default, no location. File := No_Source_File_Entry; Line := 0; - Col := 0; - - -- And no program name. - Progname := False; - - Detect_Terminal; + Offset := 0; case Origin is when Option | Library => - Progname := True; - when Elaboration => - if Loc = No_Location then - Progname := True; - else - Location_To_Position (Loc, File, Line, Col); - end if; - when Scan => - if Loc = No_Location then - File := Scanner.Get_Current_Source_File; - Line := Scanner.Get_Current_Line; - Col := Scanner.Get_Current_Column; - else - Location_To_Position (Loc, File, Line, Col); - end if; - when Parse => - if Loc = No_Location then - File := Scanner.Get_Current_Source_File; - Line := Scanner.Get_Current_Line; - Col := Scanner.Get_Token_Column; - else - Location_To_Position (Loc, File, Line, Col); - end if; - when Semantic => - if Loc = No_Location then - File := No_Source_File_Entry; - Line := 0; - Col := 0; + pragma Assert (Loc = No_Location); + null; + when others => + if Loc /= No_Location then + Location_To_Coord (Loc, File, Line_Pos, Line, Offset); else - Location_To_Position (Loc, File, Line, Col); + case Origin is + when Option + | Library => + raise Program_Error; + when Elaboration => + null; + when Scan => + File := Scanner.Get_Current_Source_File; + Line := Scanner.Get_Current_Line; + Offset := Scanner.Get_Current_Offset; + when Parse => + File := Scanner.Get_Current_Source_File; + Line := Scanner.Get_Current_Line; + Offset := Scanner.Get_Token_Offset; + when Semantic => + null; + end case; end if; end case; - Msg_Len := 0; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_Locus); - end if; - - if Progname then - Disp_Program_Name; - elsif File /= No_Source_File_Entry then - Disp_Location (Get_File_Name (File), Line, Col); - else - Disp_Location (Null_Identifier, 0, 0); - end if; - - -- Display level. - declare - Id_Level : Msgid_Type; - begin - if Flags.Warn_Error - and then (Id = Msgid_Warning or Id in Msgid_Warnings) - then - Id_Level := Msgid_Error; - else - Id_Level := Id; - end if; - - case Id_Level is - when Msgid_Note => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Note); - end if; - Put ("note:"); - when Msgid_Warning | Msgid_Warnings => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Warning); - end if; - Put ("warning:"); - when Msgid_Error => - Nbr_Errors := Nbr_Errors + 1; - if Flag_Color_Diagnostics = On then - Set_Color (Color_Error); - end if; - if Msg_Len = 0 - or else Flag_Color_Diagnostics = On - then - -- 'error:' is displayed only if not location is present, or - -- if messages are colored. - Put ("error:"); - end if; - when Msgid_Fatal => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Fatal); - end if; - Put ("fatal:"); - end case; - end; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_Message); - end if; - Put (' '); + Report_Handler.Error_Start + (Err => (Origin, File, Line, Offset, Id, Cont)); -- Display message. declare @@ -439,13 +265,13 @@ package body Errorout is Argn := Args'First; while N <= Msg'Last loop if Msg (N) = '%' then - Put (Msg (First .. N - 1)); + Report_Handler.Message (Msg (First .. N - 1)); First := N + 2; pragma Assert (N < Msg'Last); N := N + 1; case Msg (N) is when '%' => - Put ('%'); + Report_Handler.Message ("%"); Argn := Argn - 1; when 'i' => -- Identifier. @@ -453,7 +279,7 @@ package body Errorout is Arg : Earg_Type renames Args (Argn); Id : Name_Id; begin - Put ('"'); + Report_Handler.Message (""""); case Arg.Kind is when Earg_Iir => Id := Get_Identifier (Arg.Val_Iir); @@ -463,23 +289,23 @@ package body Errorout is -- Invalid conversion to identifier. raise Internal_Error; end case; - Put (Name_Table.Image (Id)); - Put ('"'); + Report_Handler.Message (Name_Table.Image (Id)); + Report_Handler.Message (""""); end; when 'c' => -- Character declare Arg : Earg_Type renames Args (Argn); begin - Put ('''); + Report_Handler.Message ("'"); case Arg.Kind is when Earg_Char => - Put (Arg.Val_Char); + Report_Handler.Message ((1 => Arg.Val_Char)); when others => -- Invalid conversion to character. raise Internal_Error; end case; - Put ('''); + Report_Handler.Message ("'"); end; when 't' => -- A token @@ -495,13 +321,16 @@ package body Errorout is -- Invalid conversion to character. raise Internal_Error; end case; - if Tok = Tok_Identifier then - Put ("an identifier"); - else - Put ('''); - Put (Image (Tok)); - Put ('''); - end if; + 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 @@ -512,7 +341,6 @@ package body Errorout is Arg_Line : Natural; Arg_Col : Natural; begin - pragma Assert (not Progname); case Arg.Kind is when Earg_Location => Arg_Loc := Arg.Val_Loc; @@ -527,14 +355,15 @@ package body Errorout is -- Do not print the filename if in the same file as -- the error location. if Arg_File = File then - Put ("line "); + Report_Handler.Message ("line "); else - Put (Name_Table.Image (Get_File_Name (Arg_File))); - Put (':'); + Report_Handler.Message + (Name_Table.Image (Get_File_Name (Arg_File))); + Report_Handler.Message (":"); end if; - Disp_Natural (Arg_Line); - Put (':'); - Disp_Natural (Arg_Col); + Report_Handler.Message (Natural_Image (Arg_Line)); + Report_Handler.Message (":"); + Report_Handler.Message (Natural_Image (Arg_Col)); end; when 'n' => -- Node @@ -543,7 +372,7 @@ package body Errorout is begin case Arg.Kind is when Earg_Iir => - Put (Disp_Node (Arg.Val_Iir)); + Report_Handler.Message (Disp_Node (Arg.Val_Iir)); when others => -- Invalid conversion to node. raise Internal_Error; @@ -554,16 +383,17 @@ package body Errorout is declare Arg : Earg_Type renames Args (Argn); begin - Put ('"'); + Report_Handler.Message (""""); case Arg.Kind is when Earg_String8 => - Put (Str_Table.String_String8 - (Arg.Val_Str8.Str, Arg.Val_Str8.Len)); + 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; - Put ('"'); + Report_Handler.Message (""""); end; when others => -- Unknown format. @@ -573,32 +403,13 @@ package body Errorout is end if; N := N + 1; end loop; - Put (Msg (First .. N - 1)); + Report_Handler.Message (Msg (First .. N - 1)); -- Are all arguments displayed ? pragma Assert (Argn > Args'Last); end; - if Flag_Diagnostics_Show_Option - and then Id in Msgid_Warnings - then - Put (" [-W"); - Put (Warning_Image (Id)); - Put ("]"); - end if; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_None); - end if; - - Put_Line; - - if Flag_Caret_Diagnostics - and then (File /= No_Source_File_Entry and Line /= 0) - then - Put_Line (Extract_Expanded_Line (File, Line)); - Put_Line ((1 .. Col - 1 => ' ') & '^'); - end if; + Report_Handler.Message_End.all; end Report_Msg; procedure Error_Msg_Option_NR (Msg: String) is @@ -797,10 +608,11 @@ package body Errorout is -- Disp a bug message. procedure Error_Internal (Expr: in Iir; Msg: String := "") is + use Ada.Text_IO; pragma Unreferenced (Expr); begin - Put ("internal error: "); - Put_Line (Msg); + Put (Standard_Error, "internal error: "); + Put_Line (Standard_Error, Msg); raise Internal_Error; end Error_Internal; |