diff options
Diffstat (limited to 'src/vhdl')
| -rw-r--r-- | src/vhdl/errorout.adb | 224 | ||||
| -rw-r--r-- | src/vhdl/errorout.ads | 26 | ||||
| -rw-r--r-- | src/vhdl/iirs.ads | 2 | ||||
| -rw-r--r-- | src/vhdl/nodes_meta.adb | 4 | ||||
| -rw-r--r-- | src/vhdl/sem.adb | 2 | ||||
| -rw-r--r-- | src/vhdl/sem_expr.adb | 12 |
6 files changed, 119 insertions, 151 deletions
diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb index b529b48ed..2f6228708 100644 --- a/src/vhdl/errorout.adb +++ b/src/vhdl/errorout.adb @@ -18,7 +18,6 @@ with Ada.Text_IO; with Ada.Command_Line; with Scanner; -with Tokens; use Tokens; with Name_Table; with Iirs_Utils; use Iirs_Utils; with Files_Map; use Files_Map; @@ -56,13 +55,6 @@ package body Errorout is Put (Str (Str'First + 1 .. Str'Last)); end Disp_Natural; - procedure Error_Msg (Msg: String) is - begin - Put (Ada.Command_Line.Command_Name); - Put (": "); - Put_Line (Msg); - end Error_Msg; - procedure Error_Kind (Msg : String; An_Iir : Iir) is begin Put_Line (Msg & ": cannot handle " @@ -86,19 +78,6 @@ package body Errorout is raise Internal_Error; end Error_Kind; - procedure Error_Msg_Option_NR (Msg: String) is - begin - Put (Ada.Command_Line.Command_Name); - Put (": "); - Put_Line (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 Disp_Location (File: Name_Id; Line: Natural; Col: Natural) is begin @@ -139,6 +118,62 @@ package body Errorout is end if; end Disp_Location; + procedure Report_Msg (Level : Report_Level; + Origin : Report_Origin; + Loc : Location_Type; + Msg : String) is + begin + case Origin is + when Option + | Library => + Put (Ada.Command_Line.Command_Name); + when Scan => + if Loc = No_Location then + Disp_Current_Location; + else + Disp_Location (Loc); + end if; + when Parse => + if Loc = No_Location then + Disp_Token_Location; + else + Disp_Location (Loc); + end if; + when Semantic + | Elaboration => + Disp_Location (Loc); + end case; + + case Level is + when Note => + Put ("note"); + when Warning => + if Flags.Warn_Error then + Nbr_Errors := Nbr_Errors + 1; + else + Put ("warning"); + end if; + when Error => + Nbr_Errors := Nbr_Errors + 1; + when Fatal => + Put ("fatal"); + end case; + + Put (": "); + Put_Line (Msg); + end Report_Msg; + + procedure Error_Msg_Option_NR (Msg: String) is + begin + Report_Msg (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; + function Get_Location_Safe (N : Iir) return Location_Type is begin if N = Null_Iir then @@ -153,45 +188,12 @@ package body Errorout is Disp_Location (Get_Location_Safe (An_Iir)); end Disp_Iir_Location; - procedure Disp_PSL_Location (N : PSL_Node) is - begin - Disp_Location (PSL.Nodes.Get_Location (N)); - end Disp_PSL_Location; - - procedure Warning_Msg (Msg: String) is - begin - Put ("warning: "); - Put_Line (Msg); - end Warning_Msg; - - procedure Warning_Msg_Parse (Msg: String) is - begin - if Flags.Flag_Only_Elab_Warnings then - return; - end if; - Disp_Token_Location; - if Flags.Warn_Error then - Nbr_Errors := Nbr_Errors + 1; - Put (" "); - else - Put ("warning: "); - end if; - Put_Line (Msg); - end Warning_Msg_Parse; - procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type) is begin if Flags.Flag_Only_Elab_Warnings then return; end if; - Disp_Location (Loc); - if Flags.Warn_Error then - Nbr_Errors := Nbr_Errors + 1; - Put (" "); - else - Put ("warning: "); - end if; - Put_Line (Msg); + Report_Msg (Warning, Semantic, Loc, Msg); end Warning_Msg_Sem; procedure Warning_Msg_Sem (Msg: String; Loc : Iir) is @@ -201,14 +203,7 @@ package body Errorout is procedure Warning_Msg_Elab (Msg: String; Loc : Location_Type) is begin - Disp_Location (Loc); - if Flags.Warn_Error then - Nbr_Errors := Nbr_Errors + 1; - Put (" "); - else - Put ("warning: "); - end if; - Put_Line (Msg); + Report_Msg (Warning, Elaboration, Loc, Msg); end Warning_Msg_Elab; procedure Warning_Msg_Elab (Msg: String; Loc : Iir) is @@ -216,126 +211,92 @@ package body Errorout is Warning_Msg_Elab (Msg, Get_Location_Safe (Loc)); end Warning_Msg_Elab; - procedure Disp_Current_Token; - pragma Unreferenced (Disp_Current_Token); - - procedure Disp_Current_Token is - begin - case Scanner.Current_Token is - when Tok_Identifier => - Put ("identifier """ - & Name_Table.Image (Scanner.Current_Identifier) & """"); - when others => - Put (Token_Type'Image (Scanner.Current_Token)); - end case; - end Disp_Current_Token; - -- Disp a message during scan. procedure Error_Msg_Scan (Msg: String) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Current_Location; - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Scan, No_Location, Msg); end Error_Msg_Scan; procedure Error_Msg_Scan (Msg: String; Loc : Location_Type) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Location (Loc); - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Scan, Loc, Msg); end Error_Msg_Scan; -- Disp a message during scan. procedure Warning_Msg_Scan (Msg: String) is begin - Disp_Current_Location; - Put ("warning: "); - Put_Line (Msg); + Report_Msg (Warning, Scan, No_Location, Msg); end Warning_Msg_Scan; -- Disp a message during scan. procedure Error_Msg_Parse (Msg: String) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Token_Location; - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Parse, No_Location, Msg); end Error_Msg_Parse; procedure Error_Msg_Parse (Msg: String; Loc : Iir) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Iir_Location (Loc); - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Parse, Get_Location_Safe (Loc), Msg); end Error_Msg_Parse; procedure Error_Msg_Parse (Msg: String; Loc : Location_Type) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Location (Loc); - Put (' '); - Put_Line (Msg); + Report_Msg (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 - Nbr_Errors := Nbr_Errors + 1; - if Loc /= Null_Iir then - Disp_Iir_Location (Loc); - Put (' '); - end if; - Put_Line (Msg); + Report_Msg (Error, Semantic, Get_Location_Safe (Loc), Msg); end Error_Msg_Sem; - procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) is + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) + is use PSL.Nodes; + L : Location_Type; begin - Nbr_Errors := Nbr_Errors + 1; - if Loc /= Null_Node then - Disp_PSL_Location (Loc); - Put (' '); + if Loc = Null_Node then + L := No_Location; + else + L := PSL.Nodes.Get_Location (Loc); end if; - Put_Line (Msg); + Report_Msg (Error, Semantic, L, Msg); end Error_Msg_Sem; procedure Error_Msg_Sem (Msg: String; Loc : Location_Type) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Location (Loc); - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Semantic, Loc, Msg); end Error_Msg_Sem; - procedure Error_Msg_Sem_Relaxed (Msg : String; Loc : Iir) + procedure Error_Msg_Relaxed + (Origin : Report_Origin; Msg : String; Loc : Iir) is use Flags; + Level : Report_Level; begin if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then - Warning_Msg_Sem (Msg, Loc); + Level := Warning; else - Error_Msg_Sem (Msg, Loc); + Level := Error; end if; + Report_Msg (Level, Origin, Get_Location_Safe (Loc), Msg); + end Error_Msg_Relaxed; + + procedure Error_Msg_Sem_Relaxed (Msg : String; Loc : Iir) is + begin + Error_Msg_Relaxed (Semantic, Msg, Loc); end Error_Msg_Sem_Relaxed; -- Disp a message during elaboration. procedure Error_Msg_Elab (Msg: String) is begin - Nbr_Errors := Nbr_Errors + 1; - Put ("error: "); - Put_Line (Msg); + Report_Msg (Error, Elaboration, No_Location, Msg); end Error_Msg_Elab; procedure Error_Msg_Elab (Msg: String; Loc : Iir) is begin - Nbr_Errors := Nbr_Errors + 1; - Disp_Iir_Location (Loc); - Put (' '); - Put_Line (Msg); + Report_Msg (Error, Elaboration, Get_Location_Safe (Loc), Msg); end Error_Msg_Elab; -- Disp a bug message. @@ -1034,7 +995,8 @@ package body Errorout is end if; end Disp_Type_Of; - procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir) + procedure Error_Pure + (Origin : Report_Origin; Caller : Iir; Callee : Iir; Loc : Iir) is L : Iir; begin @@ -1043,11 +1005,11 @@ package body Errorout is else L := Loc; end if; - Error_Msg_Sem_Relaxed - ("pure " & Disp_Node (Caller) & " cannot call (impure) " + Error_Msg_Relaxed + (Origin, "pure " & Disp_Node (Caller) & " cannot call (impure) " & Disp_Node (Callee), L); - Error_Msg_Sem_Relaxed - ("(" & Disp_Node (Callee) & " is defined here)", Callee); + Error_Msg_Relaxed + (Origin, "(" & Disp_Node (Callee) & " is defined here)", Callee); end Error_Pure; procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir) diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads index 005d19129..876dec1cc 100644 --- a/src/vhdl/errorout.ads +++ b/src/vhdl/errorout.ads @@ -33,12 +33,21 @@ package Errorout is -- The number of errors (ie, number of calls to error_msg*). Nbr_Errors: Natural := 0; - -- Disp an error, prepended with program name. - procedure Error_Msg (Msg: String); - - -- 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. + type Report_Level is (Note, Warning, Error, Fatal); + 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; + Origin : Report_Origin; + Loc : Location_Type; + Msg : String); + + -- 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); @@ -50,8 +59,6 @@ package Errorout is procedure Disp_Iir_Location (An_Iir: Iir); -- Disp a warning. - procedure Warning_Msg (Msg: String); - procedure Warning_Msg_Parse (Msg: String); procedure Warning_Msg_Sem (Msg: String; Loc : Iir); procedure Warning_Msg_Sem (Msg: String; Loc : Location_Type); @@ -118,7 +125,8 @@ package Errorout is function Disp_Type_Of (Node : Iir) return String; -- Disp an error message when a pure function CALLER calls impure CALLEE. - procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir); + procedure Error_Pure + (Origin : Report_Origin; Caller : Iir; Callee : Iir; Loc : Iir); -- Report an error message as type of EXPR does not match A_TYPE. -- Location is LOC. diff --git a/src/vhdl/iirs.ads b/src/vhdl/iirs.ads index 5aa70243c..922ab472b 100644 --- a/src/vhdl/iirs.ads +++ b/src/vhdl/iirs.ads @@ -5073,7 +5073,7 @@ package Iirs is -- complete. -- These elements have direct or indirect calls to procedure whose body is -- not yet analyzed. Therefore, purity or wait checks are not complete. - -- Field: Field9 (uc) + -- Field: Field9 Of_Ref (uc) function Get_Analysis_Checks_List (Unit : Iir) return Iir_List; procedure Set_Analysis_Checks_List (Unit : Iir; List : Iir_List); diff --git a/src/vhdl/nodes_meta.adb b/src/vhdl/nodes_meta.adb index 830aeb53b..8e380ae40 100644 --- a/src/vhdl/nodes_meta.adb +++ b/src/vhdl/nodes_meta.adb @@ -1435,7 +1435,7 @@ package body Nodes_Meta is when Field_Dependence_List => return Attr_Of_Ref; when Field_Analysis_Checks_List => - return Attr_None; + return Attr_Of_Ref; when Field_Date_State => return Attr_None; when Field_Guarded_Target_State => @@ -2028,10 +2028,10 @@ package body Nodes_Meta is Field_Context_Items, Field_Chain, Field_Library_Unit, - Field_Analysis_Checks_List, Field_Design_File, Field_Hash_Chain, Field_Dependence_List, + Field_Analysis_Checks_List, -- Iir_Kind_Library_Clause Field_Identifier, Field_Has_Identifier_List, diff --git a/src/vhdl/sem.adb b/src/vhdl/sem.adb index 12ec15c3a..d89eaca65 100644 --- a/src/vhdl/sem.adb +++ b/src/vhdl/sem.adb @@ -2200,7 +2200,7 @@ package body Sem is Depth_Callee := Iir_Depth_Impure; if Kind = K_Function then -- FIXME: report call location - Error_Pure (Subprg_Bod, Callee, Null_Iir); + Error_Pure (Elaboration, Subprg_Bod, Callee, Null_Iir); end if; end if; diff --git a/src/vhdl/sem_expr.adb b/src/vhdl/sem_expr.adb index f67176b4d..da2a890d3 100644 --- a/src/vhdl/sem_expr.adb +++ b/src/vhdl/sem_expr.adb @@ -987,7 +987,7 @@ package body Sem_Expr is -- CALLEE is impure. case Get_Kind (Subprg) is when Iir_Kind_Function_Declaration => - Error_Pure (Subprg, Callee, Loc); + Error_Pure (Semantic, Subprg, Callee, Loc); when Iir_Kind_Procedure_Declaration => Set_Purity_State (Subprg, Impure); when others => @@ -996,11 +996,9 @@ package body Sem_Expr is when Iir_Kind_Procedure_Declaration => declare Depth : Iir_Int32; - Callee_Body : Iir; - Subprg_Body : Iir; + Callee_Body : constant Iir := Get_Subprogram_Body (Callee); + Subprg_Body : constant Iir := Get_Subprogram_Body (Subprg); begin - Callee_Body := Get_Subprogram_Body (Callee); - Subprg_Body := Get_Subprogram_Body (Subprg); -- Get purity depth of callee, if possible. case Get_Purity_State (Callee) is when Pure => @@ -1026,10 +1024,10 @@ package body Sem_Expr is case Get_Kind (Subprg) is when Iir_Kind_Function_Declaration => if Depth = Iir_Depth_Impure then - Error_Pure (Subprg, Callee, Loc); + Error_Pure (Semantic, Subprg, Callee, Loc); else if Depth < Get_Subprogram_Depth (Subprg) then - Error_Pure (Subprg, Callee, Loc); + Error_Pure (Semantic, Subprg, Callee, Loc); end if; end if; when Iir_Kind_Procedure_Declaration => |