diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/errorout.adb | 304 | ||||
| -rw-r--r-- | src/errorout.ads | 74 | ||||
| -rw-r--r-- | src/options.adb | 2 | ||||
| -rw-r--r-- | src/vhdl/vhdl-errors.adb | 56 | ||||
| -rw-r--r-- | src/vhdl/vhdl-errors.ads | 9 |
5 files changed, 239 insertions, 206 deletions
diff --git a/src/errorout.adb b/src/errorout.adb index 79ed35dbf..8e9edf101 100644 --- a/src/errorout.adb +++ b/src/errorout.adb @@ -20,8 +20,6 @@ with Name_Table; with Files_Map; use Files_Map; with Str_Table; -with Vhdl.Errors; use Vhdl.Errors; - package body Errorout is -- Messages in a group. -- Set to 0 for individual messages, @@ -158,21 +156,85 @@ package body Errorout is return Res; end "+"; - procedure Report_Vhdl_Token (Tok : Vhdl.Tokens.Token_Type) + procedure Output_Identifier (Id : Name_Id) is + begin + Report_Handler.Message (""""); + Report_Handler.Message (Name_Table.Image (Id)); + Report_Handler.Message (""""); + end Output_Identifier; + + procedure Output_Character (C : Character) is + begin + Report_Handler.Message ("'"); + Report_Handler.Message ((1 => C)); + Report_Handler.Message ("'"); + end Output_Character; + + 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; + + procedure Output_Location (Err : Error_Record; Loc : Location_Type) + is + Arg_File : Source_File_Entry; + Arg_Line : Natural; + Arg_Col : Natural; + begin + Location_To_Position (Loc, Arg_File, Arg_Line, Arg_Col); + + -- Do not print the filename if in the same file as + -- the error location. + if Arg_File = Err.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 Output_Location; + + procedure Output_Uns32 (V : Uns32) is - use Vhdl.Tokens; - begin - 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 Report_Vhdl_Token; + S : constant String := Uns32'Image (V); + begin + Report_Handler.Message (S (2 .. S'Last)); + end Output_Uns32; + + procedure Output_String8 (Str : String8_Len_Type) is + begin + Report_Handler.Message (""""); + Report_Handler.Message (Str_Table.String_String8 (Str.Str, Str.Len)); + Report_Handler.Message (""""); + end Output_String8; + + procedure Output_Message (S : String) is + begin + Report_Handler.Message (S); + end Output_Message; + + type Handlers_Array is array (Earg_Lang_Kind) of Earg_Handler; + Lang_Handlers : Handlers_Array := (others => null); + + procedure Register_Earg_Handler + (Kind : Earg_Kind; Handler : Earg_Handler) is + begin + if Lang_Handlers (Kind) /= null then + -- Cannot change handler. + raise Internal_Error; + end if; + Lang_Handlers (Kind) := Handler; + end Register_Earg_Handler; procedure Report_Msg (Id : Msgid_Type; Origin : Report_Origin; @@ -180,20 +242,8 @@ package body Errorout is Msg : String; Args : Earg_Arr := No_Eargs) 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; - New_Id : Msgid_Type; + Err : Error_Record; begin -- Discard warnings that aren't enabled. if Id in Msgid_Warnings and then not Is_Warning_Enabled (Id) then @@ -228,9 +278,8 @@ package body Errorout is return; end if; - Report_Handler.Error_Start - (Err => (Origin, New_Id, - Loc.File, Loc.Line, Loc.Offset, 0)); + Err := (Origin, New_Id, Loc.File, Loc.Line, Loc.Offset, 0); + Report_Handler.Error_Start (Err); if In_Group > 0 then In_Group := In_Group + 1; @@ -240,6 +289,7 @@ package body Errorout is declare First, N : Positive; Argn : Integer; + Format : Character; begin N := Msg'First; First := N; @@ -250,145 +300,60 @@ package body Errorout is 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_Vhdl_Node => - Id := Vhdl.Nodes.Get_Identifier - (Arg.Val_Vhdl_Node); - 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. + Format := Msg (N); + if Format = '%' then + -- Special case because there is no argument for the + -- escape format. + Report_Handler.Message ("%"); + else + declare + Arg : Earg_Type renames Args (Argn); + begin + case Arg.Kind is + when Earg_None => + raise Internal_Error; + when Earg_Location => + if Format = 'l' then + Output_Location (Err, Arg.Val_Loc); + else raise Internal_Error; - end case; - Report_Handler.Message ("'"); - end; - when 't' => - -- A token - declare - Arg : Earg_Type renames Args (Argn); - begin - case Arg.Kind is - when Earg_Vhdl_Token => - Report_Vhdl_Token (Arg.Val_Vhdl_Tok); - when others => - -- Invalid conversion to character. + end if; + when Earg_Id => + if Format = 'i' then + Output_Identifier (Arg.Val_Id); + else raise Internal_Error; - 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_Vhdl_Node => - Arg_Loc := Vhdl.Nodes.Get_Location - (Arg.Val_Vhdl_Node); - when others => + end if; + when Earg_Char => + if Format = 'c' then + Output_Character (Arg.Val_Char); + else 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 = Loc.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_Vhdl_Node => - Report_Handler.Message - (Disp_Node (Arg.Val_Vhdl_Node)); - when others => - -- Invalid conversion to node. + end if; + when Earg_String8 => + if Format = 's' then + Output_String8 (Arg.Val_Str8); + else 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. + end if; + when Earg_Uns32 => + if Format = 'v' then + Output_Uns32 (Arg.Val_Uns32); + else raise Internal_Error; - end case; - Report_Handler.Message (""""); - end; - when 'v' => - -- Numerical values - declare - Arg : Earg_Type renames Args (Argn); - begin - case Arg.Kind is - when Earg_Uns32 => - declare - S : constant String := - Uns32'Image (Arg.Val_Uns32); - begin - Report_Handler.Message (S (2 .. S'Last)); - end; - when others => + end if; + when Earg_Int32 => + raise Internal_Error; + when Earg_Lang_Kind => + if Lang_Handlers (Arg.Kind) = null then raise Internal_Error; - end case; - end; - when others => - -- Unknown format. - raise Internal_Error; - end case; - Argn := Argn + 1; + end if; + Lang_Handlers (Arg.Kind) + (Format, Err, Arg.Val_Lang); + end case; + end; + Argn := Argn + 1; + end if; end if; N := N + 1; end loop; @@ -425,14 +390,13 @@ package body Errorout is Report_Msg (Id, Option, No_Source_Coord, Msg); end Warning_Msg_Option; - function Make_Earg_Vhdl_Node (V : Vhdl.Nodes.Iir) return Earg_Type is + function Make_Earg_Vhdl_Node (V : Uns32) return Earg_Type is begin - return (Kind => Earg_Vhdl_Node, Val_Vhdl_Node => V); + return (Kind => Earg_Vhdl_Node, Val_Lang => V); end Make_Earg_Vhdl_Node; - function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) - return Earg_Type is + function Make_Earg_Vhdl_Token (V : Uns32) return Earg_Type is begin - return (Kind => Earg_Vhdl_Token, Val_Vhdl_Tok => V); + return (Kind => Earg_Vhdl_Token, Val_Lang => V); end Make_Earg_Vhdl_Token; end Errorout; diff --git a/src/errorout.ads b/src/errorout.ads index 2c40d0047..bd6e08e50 100644 --- a/src/errorout.ads +++ b/src/errorout.ads @@ -16,8 +16,6 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. with Types; use Types; -with Vhdl.Nodes; -with Vhdl.Tokens; package Errorout is Compilation_Error: exception; @@ -180,6 +178,31 @@ package Errorout is type Report_Origin is (Option, Library, Scan, Parse, Semantic, Elaboration); + -- Generic report message. + -- If ORIGIN is Option or Library, LOC must be No_Source_Coord and the + -- program name is displayed. + procedure Report_Msg (Id : Msgid_Type; + Origin : Report_Origin; + Loc : Source_Coord_Type; + Msg : String; + Args : Earg_Arr := No_Eargs); + + -- Group several messages (for multi-lines messages). + -- Report_Start_Group must be called before the first Report_Msg call, + -- and Report_End_Group after the last one. + procedure Report_Start_Group; + procedure Report_End_Group; + + -- Disp an error, prepended with program name. + -- This is used for errors before initialisation, such as bad option or + -- bad filename. + procedure Error_Msg_Option (Msg: String); + + -- Warn about an option. + procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); + + -- Low level part. + type Error_Record is record Origin : Report_Origin; Id : Msgid_Type; @@ -213,38 +236,27 @@ package Errorout is procedure Set_Report_Handler (Handler : Report_Msg_Handler); - -- Generic report message. - -- If ORIGIN is Option or Library, LOC must be No_Source_Coord and the - -- program name is displayed. - procedure Report_Msg (Id : Msgid_Type; - Origin : Report_Origin; - Loc : Source_Coord_Type; - Msg : String; - Args : Earg_Arr := No_Eargs); - - -- Group several messages (for multi-lines messages). - -- Report_Start_Group must be called before the first Report_Msg call, - -- and Report_End_Group after the last one. - procedure Report_Start_Group; - procedure Report_End_Group; - - -- Disp an error, prepended with program name. - -- This is used for errors before initialisation, such as bad option or - -- bad filename. - procedure Error_Msg_Option (Msg: String); - - -- Warn about an option. - procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); - - function Make_Earg_Vhdl_Node (V : Vhdl.Nodes.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_Location, Earg_Id, Earg_Char, Earg_String8, Earg_Uns32, Earg_Int32, Earg_Vhdl_Node, Earg_Vhdl_Token); + subtype Earg_Lang_Kind is Earg_Kind range Earg_Vhdl_Node .. Earg_Kind'Last; + + type Earg_Handler is + access procedure (Format : Character; Err : Error_Record; Val : Uns32); + + procedure Register_Earg_Handler (Kind : Earg_Kind; Handler : Earg_Handler); + + procedure Output_Identifier (Id : Name_Id); + procedure Output_Location (Err : Error_Record; Loc : Location_Type); + procedure Output_Message (S : String); + + function Make_Earg_Vhdl_Node (V : Uns32) return Earg_Type; + function Make_Earg_Vhdl_Token (V : Uns32) return Earg_Type; +private + type Earg_Type (Kind : Earg_Kind := Earg_None) is record case Kind is when Earg_None => @@ -261,10 +273,8 @@ private Val_Uns32 : Uns32; when Earg_Int32 => Val_Int32 : Int32; - when Earg_Vhdl_Node => - Val_Vhdl_Node : Vhdl.Nodes.Iir; - when Earg_Vhdl_Token => - Val_Vhdl_Tok : Vhdl.Tokens.Token_Type; + when Earg_Lang_Kind => + Val_Lang : Uns32; end case; end record; diff --git a/src/options.adb b/src/options.adb index b8a7ec6ad..3db68ba25 100644 --- a/src/options.adb +++ b/src/options.adb @@ -26,6 +26,7 @@ with PSL.Dump_Tree; with Vhdl.Disp_Tree; with Vhdl.Scanner; with Vhdl.Parse; +with Vhdl.Errors; with Vhdl.Back_End; use Vhdl.Back_End; with Flags; use Flags; with Files_Map; @@ -37,6 +38,7 @@ package body Options is Libraries.Init_Paths; PSL.Nodes.Init; PSL.Dump_Tree.Dump_Hdl_Node := Vhdl.Disp_Tree.Disp_Tree_For_Psl'Access; + Vhdl.Errors.Initialize; end Initialize; function Option_Warning (Opt: String; Val : Boolean) return Option_State is diff --git a/src/vhdl/vhdl-errors.adb b/src/vhdl/vhdl-errors.adb index 6fcdacf67..ad57a735c 100644 --- a/src/vhdl/vhdl-errors.adb +++ b/src/vhdl/vhdl-errors.adb @@ -999,4 +999,60 @@ package body Vhdl.Errors is end case; end Get_Mode_Name; + function "+" (V : Iir) return Earg_Type is + begin + return Make_Earg_Vhdl_Node (Uns32 (V)); + end "+"; + + function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type is + begin + return Make_Earg_Vhdl_Token (Vhdl.Tokens.Token_Type'Pos (V)); + end "+"; + + procedure Vhdl_Node_Handler + (Format : Character; Err : Error_Record; Val : Uns32) + is + N : constant Iir := Iir (Val); + begin + case Format is + when 'i' => + Output_Identifier (Get_Identifier (N)); + when 'l' => + Output_Location (Err, Get_Location (N)); + when 'n' => + Output_Message (Disp_Node (N)); + when others => + raise Internal_Error; + end case; + end Vhdl_Node_Handler; + + procedure Vhdl_Token_Handler + (Format : Character; Err : Error_Record; Val : Uns32) + is + pragma Unreferenced (Err); + use Vhdl.Tokens; + Tok : constant Token_Type := Token_Type'Val (Val); + begin + case Format is + when 't' => + case Tok is + when Tok_Identifier => + Output_Message ("an identifier"); + when Tok_Eof => + Output_Message ("end of file"); + when others => + Output_Message ("'"); + Output_Message (Image (Tok)); + Output_Message ("'"); + end case; + when others => + raise Internal_Error; + end case; + end Vhdl_Token_Handler; + + procedure Initialize is + begin + Register_Earg_Handler (Earg_Vhdl_Node, Vhdl_Node_Handler'Access); + Register_Earg_Handler (Earg_Vhdl_Token, Vhdl_Token_Handler'Access); + end Initialize; end Vhdl.Errors; diff --git a/src/vhdl/vhdl-errors.ads b/src/vhdl/vhdl-errors.ads index 97d38e7d6..98b8f1c9e 100644 --- a/src/vhdl/vhdl-errors.ads +++ b/src/vhdl/vhdl-errors.ads @@ -21,16 +21,17 @@ with Vhdl.Nodes; use Vhdl.Nodes; with Vhdl.Tokens; package Vhdl.Errors is + -- Register handlers so that errors can be handled. + procedure Initialize; + -- This kind can't be handled. procedure Error_Kind (Msg: String; N : Iir); procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions); pragma No_Return (Error_Kind); -- Conversions - function "+" (V : Iir) return Earg_Type - renames Errorout.Make_Earg_Vhdl_Node; - function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type - renames Errorout.Make_Earg_Vhdl_Token; + function "+" (V : Iir) return Earg_Type; + function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type; -- Convert location. function "+" (L : Iir) return Location_Type; |