aboutsummaryrefslogtreecommitdiffstats
path: root/src/vhdl/errorout.adb
diff options
context:
space:
mode:
Diffstat (limited to 'src/vhdl/errorout.adb')
-rw-r--r--src/vhdl/errorout.adb404
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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-25 13:23:57 +0000