From 987a94c378dfb969e8bb7f1b734f29a33e63212e Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Thu, 9 May 2019 18:24:08 +0200 Subject: Move errorout from vhdl/ to src/ --- src/vhdl/errorout-console.adb | 261 ------------------------- src/vhdl/errorout-console.ads | 31 --- src/vhdl/errorout-memory.adb | 103 ---------- src/vhdl/errorout-memory.ads | 38 ---- src/vhdl/errorout.adb | 437 ------------------------------------------ src/vhdl/errorout.ads | 274 -------------------------- 6 files changed, 1144 deletions(-) delete mode 100644 src/vhdl/errorout-console.adb delete mode 100644 src/vhdl/errorout-console.ads delete mode 100644 src/vhdl/errorout-memory.adb delete mode 100644 src/vhdl/errorout-memory.ads delete mode 100644 src/vhdl/errorout.adb delete mode 100644 src/vhdl/errorout.ads (limited to 'src/vhdl') diff --git a/src/vhdl/errorout-console.adb b/src/vhdl/errorout-console.adb deleted file mode 100644 index 0e9694811..000000000 --- a/src/vhdl/errorout-console.adb +++ /dev/null @@ -1,261 +0,0 @@ --- 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. - case E.Id 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 => - 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; - - 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 ((Console_Error_Start'Access, - Console_Message'Access, - Console_Message_End'Access)); - end Install_Handler; -end Errorout.Console; diff --git a/src/vhdl/errorout-console.ads b/src/vhdl/errorout-console.ads deleted file mode 100644 index 9ec2f6d80..000000000 --- a/src/vhdl/errorout-console.ads +++ /dev/null @@ -1,31 +0,0 @@ --- 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-memory.adb b/src/vhdl/errorout-memory.adb deleted file mode 100644 index 83b694b74..000000000 --- a/src/vhdl/errorout-memory.adb +++ /dev/null @@ -1,103 +0,0 @@ --- Store error messages --- 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 Tables; - -package body Errorout.Memory is - - type Char_Index is new Uns32; - - package Messages is new Tables - (Table_Component_Type => Character, - Table_Index_Type => Char_Index, - Table_Low_Bound => 1, - Table_Initial => 128); - - type Error_Element is record - Header : Error_Record; - Str : Char_Index; - end record; - - package Errors is new Tables - (Table_Component_Type => Error_Element, - Table_Index_Type => Error_Index, - Table_Low_Bound => 1, - Table_Initial => 32); - - function Get_Nbr_Messages return Error_Index is - begin - return Errors.Last; - end Get_Nbr_Messages; - - function Get_Error_Record (Idx : Error_Index) return Error_Record is - begin - return Errors.Table (Idx).Header; - end Get_Error_Record; - - function Get_Error_Message (Idx : Error_Index) return String - is - First : constant Char_Index := Errors.Table (Idx).Str; - Last : Char_Index; - begin - if Idx = Errors.Last then - Last := Messages.Last; - else - Last := Errors.Table (Idx + 1).Str - 1; - end if; - return String (Messages.Table (First .. Last - 1)); - end Get_Error_Message; - - function Get_Error_Message_Addr (Idx : Error_Index) return System.Address - is - First : constant Char_Index := Errors.Table (Idx).Str; - begin - return Messages.Table (First)'Address; - end Get_Error_Message_Addr; - - procedure Clear_Errors is - begin - Errors.Init; - Messages.Init; - Nbr_Errors := 0; - end Clear_Errors; - - procedure Memory_Error_Start (E : Error_Record) is - begin - Errors.Append ((E, Messages.Last + 1)); - end Memory_Error_Start; - - procedure Memory_Message (Str : String) is - begin - for I in Str'Range loop - Messages.Append (Str (I)); - end loop; - end Memory_Message; - - procedure Memory_Message_End is - begin - Messages.Append (ASCII.NUL); - end Memory_Message_End; - - procedure Install_Handler is - begin - Set_Report_Handler ((Memory_Error_Start'Access, - Memory_Message'Access, - Memory_Message_End'Access)); - end Install_Handler; - -end Errorout.Memory; diff --git a/src/vhdl/errorout-memory.ads b/src/vhdl/errorout-memory.ads deleted file mode 100644 index 4c638671e..000000000 --- a/src/vhdl/errorout-memory.ads +++ /dev/null @@ -1,38 +0,0 @@ --- Store error messages --- 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 System; - -package Errorout.Memory is - type Error_Index is new Uns32; - - -- Get number of messages available. - function Get_Nbr_Messages return Error_Index; - - -- Get messages. - -- Idx is from 1 to Nbr_Messages. - function Get_Error_Record (Idx : Error_Index) return Error_Record; - function Get_Error_Message (Idx : Error_Index) return String; - function Get_Error_Message_Addr (Idx : Error_Index) return System.Address; - - -- Remove all error messages. - procedure Clear_Errors; - - -- Install the handlers for reporting errors. - procedure Install_Handler; -end Errorout.Memory; diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb deleted file mode 100644 index 1b022391d..000000000 --- a/src/vhdl/errorout.adb +++ /dev/null @@ -1,437 +0,0 @@ --- 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; diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads deleted file mode 100644 index 1abacca3a..000000000 --- a/src/vhdl/errorout.ads +++ /dev/null @@ -1,274 +0,0 @@ --- 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 Types; use Types; -with Vhdl.Nodes; use Vhdl.Nodes; -with Vhdl.Tokens; - -package Errorout is - Option_Error: exception; - Compilation_Error: exception; - - -- This kind can't be handled. - procedure Error_Kind (Msg : String; N : PSL_Node); - pragma No_Return (Error_Kind); - - -- The number of errors (ie, number of calls to error_msg*). - Nbr_Errors : Natural := 0; - - -- Maximum number of errors, before silent them. - Max_Nbr_Errors : constant Natural := 100; - - type Msgid_Type is - ( - -- Any note - Msgid_Note, - - -- Specific warnings - - -- Design unit redefines another design unit. - Warnid_Library, - - -- Missing Xref in pretty print. - Warnid_Missing_Xref, - - -- No default binding for a component instantiation. - Warnid_Default_Binding, - - -- Unbound component. - Warnid_Binding, - - -- Unconnected IN port without defaults (in relaxed mode). - Warnid_Port, - - -- Vhdl93 reserved word is used as a vhdl87 identifier. - Warnid_Reserved_Word, - - -- Start of block comment ('/*') appears in a block comment. - Warnid_Nested_Comment, - - -- Use of a tool directive. - Warnid_Directive, - - -- Weird use of parenthesis. - Warnid_Parenthesis, - - -- Generic of a vital entity is not a vital name. - Warnid_Vital_Generic, - - -- Delayed checks (checks performed at elaboration time). - Warnid_Delayed_Checks, - - -- Package body is not required but is analyzed. - Warnid_Body, - - -- An all/others specification does not apply, because there is no such - -- named entities. - Warnid_Specs, - - -- Incorrect use of universal value. - Warnid_Universal, - - -- Mismatch of bounds between actual and formal in a scalar port - -- association - Warnid_Port_Bounds, - - -- Runtime error detected at analysis time. - Warnid_Runtime_Error, - - -- Signal assignment creates a delta cycle in a postponed process. - Warnid_Delta_Cycle, - - -- Declaration of a shared variable with a non-protected type. - Warnid_Shared, - - -- A declaration hides a previous one. - Warnid_Hide, - - -- Emit a warning when a declaration is never used. - -- FIXME: currently only subprograms are handled. - Warnid_Unused, - - -- Others choice is not needed, all values are already covered. - Warnid_Others, - - -- Violation of pure rules. - Warnid_Pure, - - -- Violation of staticness rules - Warnid_Static, - - -- Any warning - Msgid_Warning, - - -- Any error - Msgid_Error, - - -- Any fatal error - Msgid_Fatal - ); - - -- All specific warning messages. - subtype Msgid_Warnings is Msgid_Type - range Warnid_Library .. Warnid_Static; - - -- Get the image of a warning. This correspond the the identifier of ID, - -- in lower case, without the Msgid_Warn_ prefix and with '_' replaced - -- by '-'. - function Warning_Image (Id : Msgid_Warnings) return String; - - -- Enable or disable a warning. - procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean); - - -- Get enable status of a warning. - function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean; - - -- State of warnings. - type Warnings_Setting is private; - - -- Global control of warnings. - -- Used to disable warnings while a referenced unit is analyzed. - procedure Save_Warnings_Setting (Res : out Warnings_Setting); - procedure Disable_All_Warnings; - procedure Restore_Warnings_Setting (Res : Warnings_Setting); - - type Earg_Type is private; - type Earg_Arr is array (Natural range <>) of Earg_Type; - - -- An empty array (for no arguments). - No_Eargs : constant Earg_Arr; - - -- Report display: - -- %%: % - -- %i: identifier - -- %c: character - -- %t: token - -- %l: location - -- %n: node name - -- %s: a string - -- TODO: %m: mode, %y: type of - function "+" (V : Location_Type) return Earg_Type; - function "+" (V : Name_Id) return Earg_Type; - function "+" (V : Character) return Earg_Type; - function "+" (V : String8_Len_Type) return Earg_Type; - - -- Convert location. - function "+" (L : PSL_Node) return Location_Type; - - -- Pass that detected the error. - type Report_Origin is - (Option, Library, Scan, Parse, Semantic, Elaboration); - - type Error_Record is record - Origin : Report_Origin; - Id : Msgid_Type; - Cont : Boolean; - File : Source_File_Entry; - - -- The first line is line 1, 0 can be used when line number is not - -- relevant. - Line : Natural; - - -- Offset in the line. The first character is at offset 0. - Offset : Natural; - - -- Length of the location (for a range). It is assumed to be on the - -- same line; use 0 when unknown. - Length : Natural; - 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. - procedure Report_Msg (Id : Msgid_Type; - Origin : Report_Origin; - Loc : Location_Type; - Msg : String; - Args : Earg_Arr := No_Eargs; - Cont : Boolean := False); - - -- Disp an error, prepended with program name, and raise option_error. - -- This is used for errors before initialisation, such as bad option or - -- bad filename. - procedure Error_Msg_Option (Msg: String); - pragma No_Return (Error_Msg_Option); - - -- Same as Error_Msg_Option but do not raise Option_Error. - procedure Error_Msg_Option_NR (Msg: String); - - -- Warn about an option. - procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); - - function Make_Earg_Vhdl_Node (V : 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_Iir, Earg_Location, Earg_Id, Earg_Char, Earg_Token, Earg_String8); - - type Earg_Type (Kind : Earg_Kind := Earg_None) is record - case Kind is - when Earg_None => - null; - when Earg_Iir => - Val_Iir : Iir; - when Earg_Location => - Val_Loc : Location_Type; - when Earg_Id => - Val_Id : Name_Id; - when Earg_Char => - Val_Char : Character; - when Earg_Token => - Val_Tok : Vhdl.Tokens.Token_Type; - when Earg_String8 => - Val_Str8 : String8_Len_Type; - end case; - end record; - - No_Eargs : constant Earg_Arr := (1 .. 0 => (Kind => Earg_None)); - - type Warning_Control_Type is record - Enabled : Boolean; - Error : Boolean; - end record; - - type Warnings_Setting is array (Msgid_Warnings) of Warning_Control_Type; - - Default_Warnings : constant Warnings_Setting := - (Warnid_Library | Warnid_Binding | Warnid_Port | Warnid_Shared - | Warnid_Runtime_Error | Warnid_Pure | Warnid_Specs - | Warnid_Hide => (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; -- cgit v1.2.3