From ad252b4268f855b7df53092826b6f6a57ce4c4e3 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Fri, 16 Nov 2018 20:46:09 +0100 Subject: errorout: split and rework. --- src/vhdl/errorout-console.adb | 274 +++++++++++++++++++++++++ src/vhdl/errorout-console.ads | 31 +++ src/vhdl/errorout.adb | 404 ++++++++++--------------------------- src/vhdl/errorout.ads | 31 ++- src/vhdl/scanner.adb | 30 +-- src/vhdl/scanner.ads | 11 +- src/vhdl/translate/ortho_front.adb | 4 + 7 files changed, 457 insertions(+), 328 deletions(-) create mode 100644 src/vhdl/errorout-console.adb create mode 100644 src/vhdl/errorout-console.ads (limited to 'src/vhdl') diff --git a/src/vhdl/errorout-console.adb b/src/vhdl/errorout-console.adb new file mode 100644 index 000000000..194b80ea4 --- /dev/null +++ b/src/vhdl/errorout-console.adb @@ -0,0 +1,274 @@ +-- Output errors on the console. +-- Copyright (C) 2018 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 Ada.Text_IO; +with GNAT.OS_Lib; +with Name_Table; +with Files_Map; use Files_Map; +with Flags; use Flags; + +package body Errorout.Console is + -- Name of the program, used to report error message. + Program_Name : String_Acc := null; + + -- Terminal. + + -- Set Flag_Color_Diagnostics to On or Off if is was Auto. + procedure Detect_Terminal + is + -- Import isatty. + function isatty (Fd : Integer) return Integer; + pragma Import (C, isatty); + + -- 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 = '\'; + 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; + + -- 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); + + -- Switch to COLOR. + procedure Set_Color (Color : Color_Type) + is + procedure Put (S : String) + is + use Ada.Text_IO; + begin + Put (Standard_Error, S); + end Put; + begin + if Flag_Color_Diagnostics = Off then + return; + end if; + + -- 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; + + Msg_Len : Natural; + Current_Error : Error_Record; + + 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 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 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 (':'); + Put (Natural_Image (Line)); + Put (':'); + Put (Natural_Image (Col)); + Put (':'); + end Disp_Location; + + procedure Console_Error_Start (E : Error_Record) + is + --- Coord_To_Position (File, Line_Pos, Offset, Name, Col); + Progname : Boolean; + begin + Current_Error := E; + + Detect_Terminal; + + -- And no program name. + Progname := False; + + case E.Origin is + when Option + | Library => + pragma Assert (E.File = No_Source_File_Entry); + Progname := True; + when Elaboration => + if E.File = No_Source_File_Entry then + Progname := True; + end if; + when others => + pragma Assert (E.File /= No_Source_File_Entry); + null; + end case; + + Msg_Len := 0; + + if Flag_Color_Diagnostics = On then + Set_Color (Color_Locus); + end if; + + if Progname then + Disp_Program_Name; + elsif E.File /= No_Source_File_Entry then + Disp_Location (Get_File_Name (E.File), E.Line, Get_Error_Col (E)); + else + Disp_Location (Null_Identifier, 0, 0); + end if; + + -- Display level. + declare + Id_Level : Msgid_Type; + begin + if Flags.Warn_Error + and then (E.Id = Msgid_Warning or E.Id in Msgid_Warnings) + then + Id_Level := Msgid_Error; + else + Id_Level := E.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 (' '); + end Console_Error_Start; + + procedure Console_Message (Str : String) renames Put; + + procedure Console_Message_End is + begin + if Flag_Diagnostics_Show_Option + and then Current_Error.Id in Msgid_Warnings + then + Put (" [-W"); + Put (Warning_Image (Current_Error.Id)); + Put ("]"); + end if; + + if Flag_Color_Diagnostics = On then + Set_Color (Color_None); + end if; + + Put_Line; + + if Flag_Caret_Diagnostics + and then (Current_Error.File /= No_Source_File_Entry + and Current_Error.Line /= 0) + then + Put_Line (Extract_Expanded_Line (Current_Error.File, + Current_Error.Line)); + Put_Line ((1 .. Get_Error_Col (Current_Error) - 1 => ' ') & '^'); + end if; + end Console_Message_End; + + procedure Install_Handler is + begin + Set_Report_Handler ((Errorout.Console.Console_Error_Start'Access, + Errorout.Console.Console_Message'Access, + Errorout.Console.Console_Message_End'Access)); + end Install_Handler; +end Errorout.Console; diff --git a/src/vhdl/errorout-console.ads b/src/vhdl/errorout-console.ads new file mode 100644 index 000000000..9ec2f6d80 --- /dev/null +++ b/src/vhdl/errorout-console.ads @@ -0,0 +1,31 @@ +-- Output errors on the console. +-- Copyright (C) 2018 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. + +package Errorout.Console is + -- Set the program name, used in error messages for options. Not displayed + -- if not initialized. + procedure Set_Program_Name (Name : String); + + -- Report handle for the console. + procedure Console_Error_Start (E : Error_Record); + procedure Console_Message (Str : String); + procedure Console_Message_End; + + -- Install the handlers for reporting errors. + procedure Install_Handler; +end Errorout.Console; 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; diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads index a6cf848a0..b0b7e53ad 100644 --- a/src/vhdl/errorout.ads +++ b/src/vhdl/errorout.ads @@ -23,10 +23,6 @@ package Errorout is Option_Error: exception; Compilation_Error: exception; - -- Set the program name, used in error messages for options. Not displayed - -- if not initialized. - procedure Set_Program_Name (Name : String); - -- This kind can't be handled. --procedure Error_Kind (Msg: String; Kind: Iir_Kind); procedure Error_Kind (Msg: String; An_Iir: in Iir); @@ -178,6 +174,27 @@ package Errorout is type Report_Origin is (Option, Library, Scan, Parse, Semantic, Elaboration); + type Error_Record is record + Origin : Report_Origin; + File : Source_File_Entry; + Line : Natural; + Offset : Natural; + Id : Msgid_Type; + Cont : Boolean; + end record; + + type Error_Start_Handler is access procedure (Err : Error_Record); + type Message_Handler is access procedure (Str : String); + type Message_End_Handler is access procedure; + + type Report_Msg_Handler is record + Error_Start : Error_Start_Handler; + Message : Message_Handler; + Message_End : Message_End_Handler; + end record; + + procedure Set_Report_Handler (Handler : Report_Msg_Handler); + -- Generic report message. LOC maybe No_Location. -- If ORIGIN is Option or Library, LOC must be No_Location and the program -- name is displayed. @@ -357,4 +374,10 @@ private | Warnid_Pure | Warnid_Specs | Warnid_Hide | Warnid_Port => (Enabled => True, Error => False), others => (Enabled => False, Error => False)); + + -- Compute the column from Error_Record E. + function Get_Error_Col (E : Error_Record) return Natural; + + -- Image of VAL, without the leading space. + function Natural_Image (Val: Natural) return String; end Errorout; diff --git a/src/vhdl/scanner.adb b/src/vhdl/scanner.adb index 1a5637e21..5d94fd470 100644 --- a/src/vhdl/scanner.adb +++ b/src/vhdl/scanner.adb @@ -243,31 +243,15 @@ package body Scanner is return Current_Context.Line_Number; end Get_Current_Line; - function Get_Current_Column return Natural - is - Col : Natural; - Name : Name_Id; + function Get_Current_Offset return Natural is begin - Coord_To_Position - (Current_Context.Source_File, - Current_Context.Line_Pos, - Integer (Current_Context.Pos - Current_Context.Line_Pos), - Name, Col); - return Col; - end Get_Current_Column; - - function Get_Token_Column return Natural - is - Col : Natural; - Name : Name_Id; + return Natural (Current_Context.Pos - Current_Context.Line_Pos); + end Get_Current_Offset; + + function Get_Token_Offset return Natural is begin - Coord_To_Position - (Current_Context.Source_File, - Current_Context.Line_Pos, - Integer (Current_Context.Token_Pos - Current_Context.Line_Pos), - Name, Col); - return Col; - end Get_Token_Column; + return Natural (Current_Context.Token_Pos - Current_Context.Line_Pos); + end Get_Token_Offset; function Get_Token_Position return Source_Ptr is begin diff --git a/src/vhdl/scanner.ads b/src/vhdl/scanner.ads index 5ed6f04db..176904cab 100644 --- a/src/vhdl/scanner.ads +++ b/src/vhdl/scanner.ads @@ -111,14 +111,15 @@ package Scanner is -- False (used by PSL). function Scan_Underscore return Boolean; - -- Get the current location, or the location of the current token. - -- Since a token cannot spread over lines, file and line of the current - -- token are the same as those of the current position. + -- Get the current location, or the location of the current token. + -- Since a token cannot spread over lines, file and line of the current + -- token are the same as those of the current position. + -- The offset is the offset in the current line. function Get_Current_Source_File return Source_File_Entry; function Get_Current_Line return Natural; - function Get_Current_Column return Natural; + function Get_Current_Offset return Natural; function Get_Token_Location return Location_Type; - function Get_Token_Column return Natural; + function Get_Token_Offset return Natural; function Get_Token_Position return Source_Ptr; function Get_Position return Source_Ptr; diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index d7dee0015..1eb8a3cd8 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -27,6 +27,7 @@ with Translation; with Sem; with Sem_Lib; use Sem_Lib; with Errorout; use Errorout; +with Errorout.Console; with GNAT.OS_Lib; with Bug; with Trans_Be; @@ -73,6 +74,9 @@ package body Ortho_Front is procedure Init is begin + -- Set program name for error message. + Errorout.Console.Install_Handler; + -- Initialize. Trans_Be.Register_Translation_Back_End; -- cgit v1.2.3