From 55da78e95df865ba2e2048e6546e4fffcfe020da Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sun, 31 Jul 2016 15:49:43 +0200 Subject: Rework warnings to have a uniq tag per warning. --- src/flags.ads | 41 -------------- src/ghdldrv/ghdlcomp.adb | 3 +- src/ghdldrv/ghdlprint.adb | 2 +- src/libraries.adb | 12 ++--- src/options.adb | 50 ++++++++--------- src/vhdl/configuration.adb | 21 ++++---- src/vhdl/errorout.adb | 107 ++++++++++++++++++++++++++----------- src/vhdl/errorout.ads | 89 +++++++++++++++++++++++++++--- src/vhdl/evaluation.adb | 36 ++++++++----- src/vhdl/ieee-vital_timing.adb | 9 ++-- src/vhdl/parse.adb | 3 +- src/vhdl/scanner.adb | 26 +++++---- src/vhdl/sem.adb | 11 ++-- src/vhdl/sem_decls.adb | 5 +- src/vhdl/sem_expr.adb | 6 ++- src/vhdl/sem_names.adb | 3 +- src/vhdl/sem_specs.adb | 32 ++++++----- src/vhdl/sem_stmts.adb | 11 ++-- src/vhdl/simulate/elaboration.adb | 3 +- src/vhdl/translate/ortho_front.adb | 2 +- src/vhdl/translate/trans-chap7.adb | 3 +- 21 files changed, 295 insertions(+), 180 deletions(-) diff --git a/src/flags.ads b/src/flags.ads index 03e9fe959..4bb6ec486 100644 --- a/src/flags.ads +++ b/src/flags.ads @@ -143,47 +143,6 @@ package Flags is -- --warn-undriven --Warn_Undriven : Boolean := False; - -- --warn-default-binding - -- Should emit a warning when there is no default binding for a component - -- instantiation. - Warn_Default_Binding : Boolean := False; - - -- --warn-binding - -- Emit a warning at elaboration for unbound component. - Warn_Binding : Boolean := True; - - -- --warn-reserved - -- Emit a warning when a vhdl93 reserved word is used as a - -- vhdl87 identifier. - Warn_Reserved_Word : Boolean := False; - - -- --warn-library - -- Emit a warning when a design unit redefines another design unit. - Warn_Library : Boolean := False; - - -- --warn-vital-generic - -- Emit a warning when a generic of a vital entity is not a vital name. - Warn_Vital_Generic : Boolean := True; - - -- --warn-delayed-checks - -- Emit warnings about delayed checks (checks performed at elaboration - -- time). - Warn_Delayed_Checks : Boolean := False; - - -- --warn-body - -- Emit a warning when a package body is not required but is analyzed. - Warn_Body : Boolean := True; - - -- --warn-specs - -- Emit a warning when an all/others specification does not apply, because - -- there is no such named entities. - Warn_Specs : Boolean := True; - - -- --warn-unused - -- Emit a warning when a declaration is never used. - -- FIXME: currently only subprograms are handled. - Warn_Unused : Boolean := True; - -- --warn-error -- Turns warnings into errors. Warn_Error : Boolean := False; diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb index 180240710..d496c148c 100644 --- a/src/ghdldrv/ghdlcomp.adb +++ b/src/ghdldrv/ghdlcomp.adb @@ -363,7 +363,8 @@ package body Ghdlcomp is -- Do late analysis checks. Unit := Get_First_Design_Unit (New_Design_File); while Unit /= Null_Iir loop - Sem.Sem_Analysis_Checks_List (Unit, Flags.Warn_Delayed_Checks); + Sem.Sem_Analysis_Checks_List + (Unit, Is_Warning_Enabled (Warnid_Delayed_Checks)); Unit := Get_Chain (Unit); end loop; diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb index 97f54ebde..f9b814404 100644 --- a/src/ghdldrv/ghdlprint.adb +++ b/src/ghdldrv/ghdlprint.adb @@ -240,7 +240,7 @@ package body Ghdlprint is Ref := Find (Loc); if Ref = Bad_Xref then Disp_Text; - Warning_Msg_Sem ("cannot find xref", Loc); + Warning_Msg_Sem ("cannot find xref", Loc, Warnid_Missing_Xref); Missing_Xref := True; return; end if; diff --git a/src/libraries.adb b/src/libraries.adb index d3bf84cdb..71ae71e46 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -50,13 +50,13 @@ package body Libraries is -- Report an error message. procedure Error_Lib_Msg (Msg : String) is begin - Report_Msg (Error, Library, No_Location, Msg); + Report_Msg (Msgid_Error, Library, No_Location, Msg); end Error_Lib_Msg; -- Report a warning message. procedure Warning_Lib_Msg (Msg : String) is begin - Report_Msg (Warning, Library, No_Location, Msg); + Report_Msg (Msgid_Warning, Library, No_Location, Msg); end Warning_Lib_Msg; -- Initialize pathes table. @@ -1005,14 +1005,14 @@ package body Libraries is -- In the same file. if Get_Date_State (Design_Unit) = Date_Analyze then -- Warns only if we are not re-analyzing the file. - if Flags.Warn_Library then + if Is_Warning_Enabled (Warnid_Library) then Warning_Msg_Sem ("redefinition of a library unit in " - & "same design file:", Unit); + & "same design file:", Unit, Warnid_Library); Warning_Msg_Sem (Disp_Node (Library_Unit) & " defined at " & Disp_Location (Library_Unit) & " is now " - & Disp_Node (New_Library_Unit), Unit); + & Disp_Node (New_Library_Unit), Unit, Warnid_Library); end if; else -- Free the stub. @@ -1024,7 +1024,7 @@ package body Libraries is -- Note: the current design unit should not be freed if -- in use; unfortunatly, this is not obvious to check. else - if Flags.Warn_Library then + if Is_Warning_Enabled (Warnid_Library) then if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit) then Warning_Lib_Msg diff --git a/src/options.adb b/src/options.adb index c5feac2fe..ccc2e534f 100644 --- a/src/options.adb +++ b/src/options.adb @@ -17,7 +17,7 @@ -- 02111-1307, USA. with Ada.Text_IO; use Ada.Text_IO; with Name_Table; -with Errorout; +with Errorout; use Errorout; with Libraries; with Std_Names; with PSL.Nodes; @@ -38,32 +38,28 @@ package body Options is function Option_Warning (Opt: String; Val : Boolean) return Boolean is begin --- if Opt = "undriven" then --- Warn_Undriven := True; - if Opt = "library" then - Warn_Library := Val; - elsif Opt = "default-binding" then - Warn_Default_Binding := Val; - elsif Opt = "binding" then - Warn_Binding := Val; - elsif Opt = "reserved" then - Warn_Reserved_Word := Val; - elsif Opt = "vital-generic" then - Warn_Vital_Generic := Val; - elsif Opt = "delayed-checks" then - Warn_Delayed_Checks := Val; - elsif Opt = "body" then - Warn_Body := Val; - elsif Opt = "specs" then - Warn_Specs := Val; - elsif Opt = "unused" then - Warn_Unused := Val; - elsif Opt = "error" then + -- Handle -Werror. + if Opt = "error" then Warn_Error := Val; - else - return False; + return True; end if; - return True; + + -- Normal warnings. + for I in Msgid_Warnings loop + if Warning_Image (I) = Opt then + Enable_Warning (I, Val); + return True; + end if; + end loop; + + -- -Wreserved is an alias for -Wreserved-word. + if Opt = "reserved" then + Enable_Warning (Warnid_Reserved_Word, Val); + return True; + end if; + + -- Unknown warning. + return False; end Option_Warning; function Parse_Option (Option : String) return Boolean @@ -95,12 +91,12 @@ package body Options is AMS_Vhdl := True; elsif Opt'Length >= 2 and then Opt (1 .. 2) = "-P" then if Opt'Last = 2 then - Errorout.Error_Msg_Option ("missing directory after -P"); + Error_Msg_Option ("missing directory after -P"); return True; end if; if Opt (3) = '=' then if Opt'Last = 3 then - Errorout.Error_Msg_Option ("missing directory after -P="); + Error_Msg_Option ("missing directory after -P="); return True; end if; Libraries.Add_Library_Path (Opt (4 .. Opt'Last)); diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb index c4bc0434f..671514e46 100644 --- a/src/vhdl/configuration.adb +++ b/src/vhdl/configuration.adb @@ -67,10 +67,11 @@ package body Configuration is -- May be enabled to debug dependency construction. if False then if From = Null_Iir then - Warning_Msg_Elab (Disp_Node (Unit) & " added", Unit); + Report_Msg (Msgid_Note, Elaboration, Get_Location (Unit), + Disp_Node (Unit) & " added"); else - Warning_Msg_Elab - (Disp_Node (Unit) & " added by " & Disp_Node (From), From); + Report_Msg (Msgid_Note, Elaboration, Get_Location (From), + Disp_Node (Unit) & " added by " & Disp_Node (From)); end if; end if; @@ -424,13 +425,15 @@ package body Configuration is if Get_Kind (Assoc) = Iir_Kind_Association_Element_Open then Formal := Get_Association_Interface (Assoc); Err := Err or Check_Open_Port (Formal, Assoc); - if Flags.Warn_Binding and then not Get_Artificial_Flag (Assoc) then + if Is_Warning_Enabled (Warnid_Binding) + and then not Get_Artificial_Flag (Assoc) + then Warning_Msg_Elab (Disp_Node (Formal) & " of " & Disp_Node (Get_Parent (Formal)) - & " is not bound", Assoc); + & " is not bound", Assoc, Warnid_Binding); Warning_Msg_Elab ("(in " & Disp_Node (Current_Configuration) & ")", - Current_Configuration); + Current_Configuration, Warnid_Binding); end if; end if; Assoc := Get_Chain (Assoc); @@ -516,13 +519,13 @@ package body Configuration is Inst : Iir; begin if Bind = Null_Iir then - if Flags.Warn_Binding then + if Is_Warning_Enabled (Warnid_Binding) then Inst := Get_First_Element (Get_Instantiation_List (Conf)); Warning_Msg_Elab - (Disp_Node (Inst) & " is not bound", Conf); + (Disp_Node (Inst) & " is not bound", Conf, Warnid_Binding); Warning_Msg_Elab ("(in " & Disp_Node (Current_Configuration) & ")", - Current_Configuration); + Current_Configuration, Warnid_Binding); end if; return; end if; diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb index 0da1dc166..680160098 100644 --- a/src/vhdl/errorout.adb +++ b/src/vhdl/errorout.adb @@ -30,6 +30,51 @@ package body Errorout is -- If True, disp original source line and a caret indicating the column. Flag_Show_Caret : constant Boolean := False; + type Warning_Control_Type is record + Enabled : Boolean; + Error : Boolean; + end record; + + type Warnings_Array is array (Msgid_Warnings) of Warning_Control_Type; + + Warnings_Control : Warnings_Array := + (Warnid_Binding => (Enabled => True, Error => False), + others => (Enabled => False, Error => False)); + + 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 : 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 + 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 Put (Str : String) is use Ada.Text_IO; @@ -98,7 +143,7 @@ package body Errorout is Put (':'); end Disp_Program_Name; - procedure Report_Msg (Level : Report_Level; + procedure Report_Msg (Id : Msgid_Type; Origin : Report_Origin; Loc : Location_Type; Msg : String) @@ -173,18 +218,18 @@ package body Errorout is Put ("??:??:??:"); end if; - case Level is - when Note => + case Id is + when Msgid_Note => Put ("note:"); - when Warning => + when Msgid_Warning | Msgid_Warnings => if Flags.Warn_Error then Nbr_Errors := Nbr_Errors + 1; else Put ("warning:"); end if; - when Error => + when Msgid_Error => Nbr_Errors := Nbr_Errors + 1; - when Fatal => + when Msgid_Fatal => Put ("fatal:"); end case; @@ -215,7 +260,7 @@ package body Errorout is procedure Error_Msg_Option_NR (Msg: String) is begin - Report_Msg (Error, Option, No_Location, Msg); + Report_Msg (Msgid_Error, Option, No_Location, Msg); end Error_Msg_Option_NR; procedure Error_Msg_Option (Msg: String) is @@ -233,67 +278,69 @@ package body Errorout is end if; end Get_Location_Safe; - procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type) is + procedure Warning_Msg_Sem + (Msg: String; Loc : Location_Type; Id : Msgid_Warnings) is begin if Flags.Flag_Only_Elab_Warnings then return; end if; - Report_Msg (Warning, Semantic, Loc, Msg); + Report_Msg (Id, Semantic, Loc, Msg); end Warning_Msg_Sem; - procedure Warning_Msg_Sem (Msg: String; Loc : Iir) is + procedure Warning_Msg_Sem (Msg: String; Loc : Iir; Id : Msgid_Warnings) is begin - Warning_Msg_Sem (Msg, Get_Location_Safe (Loc)); + Warning_Msg_Sem (Msg, Get_Location_Safe (Loc), Id); end Warning_Msg_Sem; - procedure Warning_Msg_Elab (Msg: String; Loc : Location_Type) is + procedure Warning_Msg_Elab + (Msg: String; Loc : Location_Type; Id : Msgid_Warnings) is begin - Report_Msg (Warning, Elaboration, Loc, Msg); + Report_Msg (Id, Elaboration, Loc, Msg); end Warning_Msg_Elab; - procedure Warning_Msg_Elab (Msg: String; Loc : Iir) is + procedure Warning_Msg_Elab (Msg: String; Loc : Iir; Id : Msgid_Warnings) is begin - Warning_Msg_Elab (Msg, Get_Location_Safe (Loc)); + Warning_Msg_Elab (Msg, Get_Location_Safe (Loc), Id); end Warning_Msg_Elab; -- Disp a message during scan. procedure Error_Msg_Scan (Msg: String) is begin - Report_Msg (Error, Scan, No_Location, Msg); + Report_Msg (Msgid_Error, Scan, No_Location, Msg); end Error_Msg_Scan; procedure Error_Msg_Scan (Msg: String; Loc : Location_Type) is begin - Report_Msg (Error, Scan, Loc, Msg); + Report_Msg (Msgid_Error, Scan, Loc, Msg); end Error_Msg_Scan; -- Disp a message during scan. - procedure Warning_Msg_Scan (Msg: String) is + procedure Warning_Msg_Scan (Msg: String; Id : Msgid_Warnings) is begin - Report_Msg (Warning, Scan, No_Location, Msg); + Report_Msg (Id, Scan, No_Location, Msg); end Warning_Msg_Scan; -- Disp a message during scan. procedure Error_Msg_Parse (Msg: String) is begin - Report_Msg (Error, Parse, No_Location, Msg); + Report_Msg (Msgid_Error, Parse, No_Location, Msg); end Error_Msg_Parse; procedure Error_Msg_Parse (Msg: String; Loc : Iir) is begin - Report_Msg (Error, Parse, Get_Location_Safe (Loc), Msg); + Report_Msg (Msgid_Error, Parse, Get_Location_Safe (Loc), Msg); end Error_Msg_Parse; procedure Error_Msg_Parse (Msg: String; Loc : Location_Type) is begin - Report_Msg (Error, Parse, Loc, Msg); + Report_Msg (Msgid_Error, Parse, Loc, Msg); end Error_Msg_Parse; -- Disp a message during semantic analysis. -- LOC is used for location and current token. procedure Error_Msg_Sem (Msg: String; Loc: in Iir) is begin - Report_Msg (Error, Semantic, Get_Location_Safe (Loc), Msg); + Report_Msg (Msgid_Error, Semantic, Get_Location_Safe (Loc), Msg); end Error_Msg_Sem; procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) @@ -306,24 +353,24 @@ package body Errorout is else L := PSL.Nodes.Get_Location (Loc); end if; - Report_Msg (Error, Semantic, L, Msg); + Report_Msg (Msgid_Error, Semantic, L, Msg); end Error_Msg_Sem; procedure Error_Msg_Sem (Msg: String; Loc : Location_Type) is begin - Report_Msg (Error, Semantic, Loc, Msg); + Report_Msg (Msgid_Error, Semantic, Loc, Msg); end Error_Msg_Sem; procedure Error_Msg_Relaxed (Origin : Report_Origin; Msg : String; Loc : Iir) is use Flags; - Level : Report_Level; + Level : Msgid_Type; begin if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then - Level := Warning; + Level := Msgid_Warning; else - Level := Error; + Level := Msgid_Error; end if; Report_Msg (Level, Origin, Get_Location_Safe (Loc), Msg); end Error_Msg_Relaxed; @@ -336,12 +383,12 @@ package body Errorout is -- Disp a message during elaboration. procedure Error_Msg_Elab (Msg: String) is begin - Report_Msg (Error, Elaboration, No_Location, Msg); + Report_Msg (Msgid_Error, Elaboration, No_Location, Msg); end Error_Msg_Elab; procedure Error_Msg_Elab (Msg: String; Loc : Iir) is begin - Report_Msg (Error, Elaboration, Get_Location_Safe (Loc), Msg); + Report_Msg (Msgid_Error, Elaboration, Get_Location_Safe (Loc), Msg); end Error_Msg_Elab; -- Disp a bug message. diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads index ab7b3fcc2..c1d219011 100644 --- a/src/vhdl/errorout.ads +++ b/src/vhdl/errorout.ads @@ -33,14 +33,90 @@ package Errorout is -- The number of errors (ie, number of calls to error_msg*). Nbr_Errors: Natural := 0; - type Report_Level is (Note, Warning, Error, Fatal); + type Msgid_Type is + (-- Any note + Msgid_Note, + + -- Any warning + Msgid_Warning, + + -- 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, + + -- Vhdl93 reserved word is used as a vhdl87 identifier. + Warnid_Reserved_Word, + + -- Start of block comment ('/*') appears in a block comment. + Warnid_Nested_Comment, + + -- 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, + + -- Runtime error detected at analysis time. + Warnid_Runtime_Error, + + -- Signal assignment creates a delta cycle in a postponed process. + Warnid_Delta_Cycle, + + -- Emit a warning when a declaration is never used. + -- FIXME: currently only subprograms are handled. + Warnid_Unused, + + -- Any error + Msgid_Error, + + -- Any fatal error + Msgid_Fatal); + + -- All specific warning messages. + subtype Msgid_Warnings is Msgid_Type + range Warnid_Library .. Warnid_Unused; + + -- 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; + type Report_Origin is (Option, Library, Scan, Parse, Semantic, Elaboration); -- 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 (Level : Report_Level; + procedure Report_Msg (Id : Msgid_Type; Origin : Report_Origin; Loc : Location_Type; Msg : String); @@ -55,14 +131,15 @@ package Errorout is procedure Error_Msg_Option_NR (Msg: String); -- Disp a warning. - procedure Warning_Msg_Sem (Msg: String; Loc : Iir); - procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type); + procedure Warning_Msg_Sem (Msg: String; Loc : Iir; Id : Msgid_Warnings); + procedure Warning_Msg_Sem + (Msg: String; Loc : Location_Type; Id : Msgid_Warnings); -- Disp a message during scan. -- The current location is automatically displayed before the message. procedure Error_Msg_Scan (Msg: String); procedure Error_Msg_Scan (Msg: String; Loc : Location_Type); - procedure Warning_Msg_Scan (Msg: String); + procedure Warning_Msg_Scan (Msg: String; Id : Msgid_Warnings); -- Disp a message during parse -- The location of the current token is automatically displayed before @@ -85,7 +162,7 @@ package Errorout is procedure Error_Msg_Elab (Msg: String; Loc: Iir); -- Disp a warning durig elaboration (or configuration). - procedure Warning_Msg_Elab (Msg: String; Loc : Iir); + procedure Warning_Msg_Elab (Msg: String; Loc : Iir; Id : Msgid_Warnings); -- Disp a bug message. procedure Error_Internal (Expr: Iir; Msg: String := ""); diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb index bd3b9e286..e0b52fd9f 100644 --- a/src/vhdl/evaluation.adb +++ b/src/vhdl/evaluation.adb @@ -560,7 +560,8 @@ package body Evaluation is exception when Constraint_Error => -- Can happen for absolute. - Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + Warning_Msg_Sem ("arithmetic overflow in static expression", + Orig, Warnid_Runtime_Error); return Build_Overflow (Orig); end Eval_Monadic_Operator; @@ -579,7 +580,8 @@ package body Evaluation is begin Len := Get_String_Length (Left); if Len /= Get_String_Length (Right) then - Warning_Msg_Sem ("length of left and right operands mismatch", Expr); + Warning_Msg_Sem ("length of left and right operands mismatch", + Expr, Warnid_Runtime_Error); return Build_Overflow (Expr); else Id := Create_String8; @@ -678,7 +680,7 @@ package body Evaluation is is begin if Get_Value (Val) = 0 then - Warning_Msg_Sem ("division by 0", Expr); + Warning_Msg_Sem ("division by 0", Expr, Warnid_Runtime_Error); return False; else return True; @@ -1125,7 +1127,8 @@ package body Evaluation is (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); when Iir_Predefined_Floating_Div => if Get_Fp_Value (Right) = 0.0 then - Warning_Msg_Sem ("right operand of division is 0", Orig); + Warning_Msg_Sem ("right operand of division is 0", + Orig, Warnid_Runtime_Error); return Build_Overflow (Orig); else return Build_Floating @@ -1452,7 +1455,8 @@ package body Evaluation is end case; exception when Constraint_Error => - Warning_Msg_Sem ("arithmetic overflow in static expression", Orig); + Warning_Msg_Sem ("arithmetic overflow in static expression", + Orig, Warnid_Runtime_Error); return Build_Overflow (Orig); end Eval_Dyadic_Operator; @@ -1646,7 +1650,7 @@ package body Evaluation is return Build_Constant (Res, Expr); else Warning_Msg_Sem ("value """ & Value & """ not in enumeration " - & Disp_Node (Enum), Expr); + & Disp_Node (Enum), Expr, Warnid_Runtime_Error); return Build_Overflow (Expr); end if; end Build_Enumeration_Value; @@ -1720,7 +1724,8 @@ package body Evaluation is end loop; if Unit = Null_Iir then Warning_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last) - & """ not in physical type", Expr); + & """ not in physical type", + Expr, Warnid_Runtime_Error); return Build_Overflow (Expr); end if; @@ -1803,7 +1808,8 @@ package body Evaluation is (Get_Enumeration_Literal_List (Get_Base_Type (Get_Type (Expr)))))) then - Warning_Msg_Sem ("static constant violates bounds", Expr); + Warning_Msg_Sem ("static constant violates bounds", + Expr, Warnid_Runtime_Error); return Build_Overflow (Origin); else return Build_Enumeration (Iir_Index32 (P), Origin); @@ -1861,8 +1867,8 @@ package body Evaluation is if Get_Constraint_State (Conv_Type) = Fully_Constrained then Set_Type (Res, Conv_Type); if not Eval_Is_In_Bound (Val, Conv_Type) then - Warning_Msg_Sem - ("non matching length in type conversion", Conv); + Warning_Msg_Sem ("non matching length in type conversion", + Conv, Warnid_Runtime_Error); return Build_Overflow (Conv); end if; return Res; @@ -1931,7 +1937,8 @@ package body Evaluation is end if; if not Eval_Is_In_Bound (Res, Get_Type (Expr)) then if Get_Kind (Res) /= Iir_Kind_Overflow_Literal then - Warning_Msg_Sem ("result of conversion out of bounds", Expr); + Warning_Msg_Sem ("result of conversion out of bounds", + Expr, Warnid_Runtime_Error); Res := Build_Overflow (Res); end if; end if; @@ -2117,8 +2124,8 @@ package body Evaluation is and then not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) then - Warning_Msg_Sem - ("static argument out of the type range", Expr); + Warning_Msg_Sem ("static argument out of the type range", + Expr, Warnid_Runtime_Error); return Build_Overflow (Expr); end if; if Get_Kind (Get_Base_Type (Get_Type (Expr))) @@ -2166,7 +2173,8 @@ package body Evaluation is Set_Parameter (Expr, Param); if Get_Kind (Param) /= Iir_Kind_String_Literal8 then -- FIXME: Isn't it an implementation restriction. - Warning_Msg_Sem ("'value argument not a string", Expr); + Warning_Msg_Sem ("'value argument not a string", + Expr, Warnid_Runtime_Error); return Build_Overflow (Expr); else return Eval_Value_Attribute diff --git a/src/vhdl/ieee-vital_timing.adb b/src/vhdl/ieee-vital_timing.adb index 915ad00a6..fb92efaf7 100644 --- a/src/vhdl/ieee-vital_timing.adb +++ b/src/vhdl/ieee-vital_timing.adb @@ -27,7 +27,6 @@ with Sem_Specs; with Evaluation; with Sem; with Iirs_Utils; -with Flags; package body Ieee.Vital_Timing is -- This package is based on IEEE 1076.4 1995. @@ -189,7 +188,11 @@ package body Ieee.Vital_Timing is procedure Error_Vital (Msg : String; Loc : Iir) renames Error_Msg_Sem; procedure Error_Vital (Msg : String; Loc : Location_Type) renames Error_Msg_Sem; - procedure Warning_Vital (Msg : String; Loc : Iir) renames Warning_Msg_Sem; + + procedure Warning_Vital (Msg : String; Loc : Iir) is + begin + Warning_Msg_Sem (Msg, Loc, Warnid_Vital_Generic); + end Warning_Vital; -- Check DECL is the VITAL level 0 attribute specification. procedure Check_Level0_Attribute_Specification (Decl : Iir) @@ -1255,7 +1258,7 @@ package body Ieee.Vital_Timing is return; end if; - if Flags.Warn_Vital_Generic then + if Is_Warning_Enabled (Warnid_Vital_Generic) then Warning_Vital (Disp_Node (Decl) & " is not a VITAL generic", Decl); end if; end Check_Entity_Generic_Declaration; diff --git a/src/vhdl/parse.adb b/src/vhdl/parse.adb index eaab1351f..6991b8c7b 100644 --- a/src/vhdl/parse.adb +++ b/src/vhdl/parse.adb @@ -4072,7 +4072,8 @@ package body Parse is -- Parenthesis around aggregate is useless and change the -- context for array aggregate. Warning_Msg_Sem - ("suspicious parenthesis around aggregate", Expr); + ("suspicious parenthesis around aggregate", + Expr, Warnid_Parenthesis); elsif not Flag_Parse_Parenthesis then return Expr; end if; diff --git a/src/vhdl/scanner.adb b/src/vhdl/scanner.adb index b56c04e9a..7c5dbdd00 100644 --- a/src/vhdl/scanner.adb +++ b/src/vhdl/scanner.adb @@ -931,39 +931,44 @@ package body Scanner is case Current_Identifier is when Std_Names.Name_Id_AMS_Reserved_Words => if not AMS_Vhdl then - if Flags.Warn_Reserved_Word then + if Is_Warning_Enabled (Warnid_Reserved_Word) then Warning_Msg_Scan ("using """ & Nam_Buffer (1 .. Nam_Length) - & """ AMS-VHDL reserved word as an identifier"); + & """ AMS-VHDL reserved word as an identifier", + Warnid_Reserved_Word); end if; Current_Token := Tok_Identifier; end if; when Std_Names.Name_Id_Vhdl08_Reserved_Words => if Vhdl_Std < Vhdl_08 then - if Flags.Warn_Reserved_Word then + if Is_Warning_Enabled (Warnid_Reserved_Word) then Warning_Msg_Scan ("using """ & Nam_Buffer (1 .. Nam_Length) - & """ vhdl-2008 reserved word as an identifier"); + & """ vhdl-2008 reserved word as an identifier", + Warnid_Reserved_Word); end if; Current_Token := Tok_Identifier; end if; when Std_Names.Name_Id_Vhdl00_Reserved_Words => if Vhdl_Std < Vhdl_00 then - if Flags.Warn_Reserved_Word then + if Is_Warning_Enabled (Warnid_Reserved_Word) then Warning_Msg_Scan ("using """ & Nam_Buffer (1 .. Nam_Length) - & """ vhdl00 reserved word as an identifier"); + & """ vhdl00 reserved word as an identifier", + Warnid_Reserved_Word); end if; Current_Token := Tok_Identifier; end if; when Std_Names.Name_Id_Vhdl93_Reserved_Words => if Vhdl_Std = Vhdl_87 then - if Flags.Warn_Reserved_Word then + if Is_Warning_Enabled (Warnid_Reserved_Word) then Warning_Msg_Scan ("using """ & Nam_Buffer (1 .. Nam_Length) - & """ vhdl93 reserved word as a vhdl87 identifier"); + & """ vhdl93 reserved word as a vhdl87 identifier", + Warnid_Reserved_Word); Warning_Msg_Scan - ("(use option --std=93 to compile as vhdl93)"); + ("(use option --std=93 to compile as vhdl93)", + Warnid_Reserved_Word); end if; Current_Token := Tok_Identifier; end if; @@ -1464,7 +1469,8 @@ package body Scanner is -- the start of a nested delimited comment. if Source (Pos + 1) = '*' then Warning_Msg_Scan - ("'/*' found within a block comment"); + ("'/*' found within a block comment", + Warnid_Nested_Comment); end if; Pos := Pos + 1; when '*' => diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb index 4c31f3673..d19061846 100644 --- a/src/vhdl/sem.adb +++ b/src/vhdl/sem.adb @@ -2463,14 +2463,15 @@ package body Sem is Warning_Msg_Sem ("can't assert that all calls in " & Disp_Node (El) & " are pure or have not wait; " - & "will be checked at elaboration", El); + & "will be checked at elaboration", El, + Warnid_Delayed_Checks); Callee := Get_Nth_Element (Callees, 0); -- FIXME: could improve this message by displaying the -- chain of calls until the first subprograms in -- unknown state. Warning_Msg_Sem ("(first such call is to " & Disp_Node (Callee) & ")", - Callee); + Callee, Warnid_Delayed_Checks); end if; end if; when Iir_Kind_Sensitized_Process_Statement => @@ -2479,7 +2480,8 @@ package body Sem is if Emit_Warnings then Warning_Msg_Sem ("can't assert that " & Disp_Node (El) - & " has not wait; will be checked at elaboration", El); + & " has not wait; will be checked at elaboration", + El, Warnid_Delayed_Checks); end if; end if; when others => @@ -2633,7 +2635,8 @@ package body Sem is -- Emit a warning is a body is not necessary. if not Get_Need_Body (Package_Decl) then Warning_Msg_Sem - (Disp_Node (Package_Decl) & " does not require a body", Decl); + (Disp_Node (Package_Decl) & " does not require a body", + Decl, Warnid_Body); end if; Set_Package (Decl, Package_Decl); diff --git a/src/vhdl/sem_decls.adb b/src/vhdl/sem_decls.adb index e05f2c552..48c3ae2d9 100644 --- a/src/vhdl/sem_decls.adb +++ b/src/vhdl/sem_decls.adb @@ -2995,7 +2995,7 @@ package body Sem_Decls is -- Set Check_Unused. Check_Unused := False; - if Flags.Warn_Unused then + if Is_Warning_Enabled (Warnid_Unused) then case Get_Kind (Decl) is when Iir_Kind_Entity_Declaration => -- May be used in architecture. @@ -3079,7 +3079,8 @@ package body Sem_Decls is and then not Is_Second_Subprogram_Specification (El) then Warning_Msg_Sem - (Disp_Node (El) & " is never referenced", El); + (Disp_Node (El) & " is never referenced", El, + Warnid_Unused); end if; when others => null; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index a856be072..10e07bf22 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -863,7 +863,7 @@ package body Sem_Expr is -- Be tolerant. Warning_Msg_Sem ("universal integer bound must be numeric literal " - & "or attribute", Res); + & "or attribute", Res, Warnid_Universal); else Error_Msg_Sem ("universal integer bound must be numeric literal " & "or attribute", Res); @@ -3431,7 +3431,9 @@ package body Sem_Expr is if not Eval_Is_In_Bound (Expr, Element_Type) then Info.Has_Bound_Error := True; - Warning_Msg_Sem ("element is out of the bounds", Expr); + Warning_Msg_Sem + ("element is out of the bounds", Expr, + Warnid_Runtime_Error); end if; -- FIXME: handle name/others in translate. diff --git a/src/vhdl/sem_names.adb b/src/vhdl/sem_names.adb index 006390332..098268daa 100644 --- a/src/vhdl/sem_names.adb +++ b/src/vhdl/sem_names.adb @@ -735,7 +735,8 @@ package body Sem_Names is if False and then Flags.Vhdl_Std = Vhdl_87 then -- emit a warning for a null slice. Warning_Msg_Sem - ("direction mismatch results in a null slice", Name); + ("direction mismatch results in a null slice", + Name, Warnid_Runtime_Error); end if; Error_Msg_Sem ("direction of the range mismatch", Name); end if; diff --git a/src/vhdl/sem_specs.adb b/src/vhdl/sem_specs.adb index bdcf64563..8b4a525f0 100644 --- a/src/vhdl/sem_specs.adb +++ b/src/vhdl/sem_specs.adb @@ -770,9 +770,10 @@ package body Sem_Specs is -- class that are declared in the immediatly enclosing -- declarative part. Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, True); - if Res = False and then Flags.Warn_Specs then + if Res = False and then Is_Warning_Enabled (Warnid_Specs) then Warning_Msg_Sem - ("attribute specification apply to no named entity", Spec); + ("attribute specification apply to no named entity", + Spec, Warnid_Specs); end if; elsif List = Iir_List_Others then -- o If the reserved word OTHERS is supplied, then the attribute @@ -782,9 +783,10 @@ package body Sem_Specs is -- in the entity name list of a previous attribute specification -- for the given attribute. Res := Sem_Named_Entities (Scope, Null_Iir, Spec, False, False); - if Res = False and then Flags.Warn_Specs then + if Res = False and then Is_Warning_Enabled (Warnid_Specs) then Warning_Msg_Sem - ("attribute specification apply to no named entity", Spec); + ("attribute specification apply to no named entity", + Spec, Warnid_Specs); end if; else -- o If a list of entity designators is supplied, then the @@ -1337,10 +1339,10 @@ package body Sem_Specs is -- statements whose corresponding instantiated units name -- component. if not Apply_Component_Specification (Parent_Stmts, False) - and then Flags.Warn_Specs + and then Is_Warning_Enabled (Warnid_Specs) then - Warning_Msg_Sem - ("component specification applies to no instance", Spec); + Warning_Msg_Sem ("component specification applies to no instance", + Spec, Warnid_Specs); end if; elsif List = Iir_List_Others then -- LRM93 5.2 @@ -1355,10 +1357,10 @@ package body Sem_Specs is -- statements whose corresponding instantiated units name -- components. if not Apply_Component_Specification (Parent_Stmts, True) - and then Flags.Warn_Specs + and then Is_Warning_Enabled (Warnid_Specs) then - Warning_Msg_Sem - ("component specification applies to no instance", Spec); + Warning_Msg_Sem ("component specification applies to no instance", + Spec, Warnid_Specs); end if; else -- LRM93 5.2 @@ -1787,7 +1789,8 @@ package body Sem_Specs is -- (see 10.3), Decl := Get_Declaration (Inter); Warning_Msg_Elab ("visible declaration for " & Name_Table.Image (Name) - & " is " & Disp_Node (Decl), Decl); + & " is " & Disp_Node (Decl), + Decl, Warnid_Default_Binding); -- b) An entity declaration that has the same simple name that of -- the instantiated component and that would be directly @@ -1798,8 +1801,9 @@ package body Sem_Specs is Inter := Get_Under_Interpretation (Name); if Valid_Interpretation (Inter) then Decl := Get_Declaration (Inter); - Warning_Msg_Elab ("interpretation behind the component is " - & Disp_Node (Decl), Comp); + Warning_Msg_Elab + ("interpretation behind the component is " & Disp_Node (Decl), + Comp, Warnid_Default_Binding); end if; end if; end if; @@ -1819,7 +1823,7 @@ package body Sem_Specs is end loop; Warning_Msg_Elab ("no entity """ & Name_Table.Image (Name) & """ in " - & Disp_Node (Decl), Comp); + & Disp_Node (Decl), Comp, Warnid_Default_Binding); end if; end Explain_No_Visible_Entity; diff --git a/src/vhdl/sem_stmts.adb b/src/vhdl/sem_stmts.adb index d0ca64a06..25c1ada95 100644 --- a/src/vhdl/sem_stmts.adb +++ b/src/vhdl/sem_stmts.adb @@ -557,7 +557,7 @@ package body Sem_Stmts is if Get_Postponed_Flag (Current_Concurrent_Statement) then Warning_Msg_Sem ("waveform may cause a delta cycle in a " & - "postponed process", We); + "postponed process", We, Warnid_Delta_Cycle); end if; when others => -- Context is a subprogram. @@ -833,7 +833,7 @@ package body Sem_Stmts is then Warning_Msg_Sem ("expression length does not match target length", - Stmt); + Stmt, Warnid_Runtime_Error); Set_Expression (Stmt, Build_Overflow (Expr, Target_Type)); end if; end if; @@ -1499,11 +1499,12 @@ package body Sem_Stmts is then Entity_Unit := Get_Visible_Entity_Declaration (Decl); if Entity_Unit = Null_Iir then - if Flags.Warn_Default_Binding + if Is_Warning_Enabled (Warnid_Default_Binding) and then not Flags.Flag_Elaborate then - Warning_Msg_Sem ("no default binding for instantiation of " - & Disp_Node (Decl), Stmt); + Warning_Msg_Sem + ("no default binding for instantiation of " + & Disp_Node (Decl), Stmt, Warnid_Default_Binding); Explain_No_Visible_Entity (Decl); end if; elsif Flags.Flag_Elaborate diff --git a/src/vhdl/simulate/elaboration.adb b/src/vhdl/simulate/elaboration.adb index a4919147c..b5f948038 100644 --- a/src/vhdl/simulate/elaboration.adb +++ b/src/vhdl/simulate/elaboration.adb @@ -1891,7 +1891,8 @@ package body Elaboration is -- declaration and architecture body or is bound to a configuration of -- such a design entity. if not Is_Fully_Bound (Conf) then - Warning_Msg_Elab (Disp_Node (Stmt) & " not bound", Stmt); + Warning_Msg_Elab + (Disp_Node (Stmt) & " not bound", Stmt, Warnid_Binding); return; end if; diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index 46f303348..2c3da3189 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -391,7 +391,7 @@ package body Ortho_Front is Design := Get_First_Design_Unit (New_Design_File); while not Is_Null (Design) loop Sem.Sem_Analysis_Checks_List - (Design, Flags.Warn_Delayed_Checks); + (Design, Is_Warning_Enabled (Warnid_Delayed_Checks)); Design := Get_Chain (Design); end loop; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 8706dd3b3..e1ae36901 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -3784,7 +3784,8 @@ package body Trans.Chap7 is return New_Lit (New_Signed_Literal (Otype, Integer_64 (Val))); exception when Constraint_Error => - Warning_Msg_Elab ("physical literal out of range", Expr); + Warning_Msg_Elab ("physical literal out of range", + Expr, Warnid_Runtime_Error); return Translate_Overflow_Literal (Expr); end; -- cgit v1.2.3