diff options
| -rw-r--r-- | src/libraries.adb | 42 | ||||
| -rw-r--r-- | src/types.ads | 1 | ||||
| -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 |
8 files changed, 148 insertions, 165 deletions
diff --git a/src/libraries.adb b/src/libraries.adb index c620c0035..63fbb890b 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -48,6 +48,18 @@ package body Libraries is Table_Initial => 4, Table_Increment => 100); + -- Report an error message. + procedure Error_Lib_Msg (Msg : String) is + begin + Report_Msg (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); + end Warning_Lib_Msg; + -- Initialize pathes table. -- Set the local path. procedure Init_Pathes @@ -76,7 +88,7 @@ package body Libraries is end if; -- Nice message instead of constraint_error. if Path'Length + 2 >= Nam_Buffer'Length then - Error_Msg ("argument of -P is too long"); + Error_Lib_Msg ("argument of -P is too long"); return; end if; Pathes.Append (Path_To_Id (Path)); @@ -102,7 +114,7 @@ package body Libraries is if not GNAT.OS_Lib.Is_Directory (Get_Address (Work_Directory)) then -- This is a warning, since 'clean' action should not fail in -- this cases. - Warning_Msg + Warning_Lib_Msg ("directory '" & Path & "' set by --workdir= does not exist"); -- raise Option_Error; end if; @@ -278,8 +290,8 @@ package body Libraries is procedure Bad_Library_Format is begin - Error_Msg (Image (Files_Map.Get_File_Name (File)) & - ": bad library format"); + Error_Lib_Msg (Image (Files_Map.Get_File_Name (File)) & + ": bad library format"); raise Compilation_Error; end Bad_Library_Format; @@ -980,11 +992,12 @@ package body Libraries is if Flags.Warn_Library then if Get_Kind (Library_Unit) /= Get_Kind (New_Library_Unit) then - Warning_Msg ("changing definition of a library unit:"); - Warning_Msg (Disp_Node (Library_Unit) & " is now " - & Disp_Node (New_Library_Unit)); + Warning_Lib_Msg + ("changing definition of a library unit:"); + Warning_Lib_Msg (Disp_Node (Library_Unit) & " is now " + & Disp_Node (New_Library_Unit)); end if; - Warning_Msg + Warning_Lib_Msg ("library unit '" & Iirs_Utils.Image_Identifier (Library_Unit) & "' was also defined in file '" @@ -1128,7 +1141,7 @@ package body Libraries is pragma Unreferenced (Close_Res); begin if Integer (fwrite (S'Address, S'Length, 1, Stream)) /= 1 then - Error_Msg + Error_Lib_Msg ("cannot write library file for " & Image_Identifier (Library)); Close_Res := fclose (Stream); Delete_File (Temp_Name'Address, Success); @@ -1158,7 +1171,7 @@ package body Libraries is Stream := fopen (Temp_Name'Address, Mode'Address); if Stream = NULL_Stream then - Error_Msg + Error_Lib_Msg ("cannot create library file for " & Image_Identifier (Library)); raise Option_Error; end if; @@ -1300,9 +1313,10 @@ package body Libraries is if not Success then -- Renaming may fail if the new filename is in a non-existant -- directory. - Error_Msg ("cannot update library file """ - & File_Name (File_Name'First .. File_Name'Last - 1) - & """"); + Error_Lib_Msg + ("cannot update library file """ + & File_Name (File_Name'First .. File_Name'Last - 1) + & """"); Delete_File (Temp_Name'Address, Success); raise Option_Error; end if; @@ -1479,7 +1493,7 @@ package body Libraries is (Get_Design_File_Directory (Design_File), Get_Design_File_Filename (Design_File)); if Fe = No_Source_File_Entry then - Error_Msg + Error_Lib_Msg ("cannot load " & Disp_Node (Get_Library_Unit (Design_Unit))); raise Compilation_Error; end if; diff --git a/src/types.ads b/src/types.ads index 7717e5fcd..db1e5bf70 100644 --- a/src/types.ads +++ b/src/types.ads @@ -99,6 +99,7 @@ package Types is type Location_Type is new Nat32; for Location_Type'Size use 32; Location_Nil : constant Location_Type := 0; + No_Location : constant Location_Type := 0; -- Type of a file buffer. type File_Buffer is array (Source_Ptr range <>) of Character; 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 => |