diff options
Diffstat (limited to 'src/vhdl/errorout.adb')
| -rw-r--r-- | src/vhdl/errorout.adb | 1113 |
1 files changed, 1113 insertions, 0 deletions
diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb new file mode 100644 index 0000000..1652bb4 --- /dev/null +++ b/src/vhdl/errorout.adb @@ -0,0 +1,1113 @@ +-- 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 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; +with Ada.Strings.Unbounded; +with Std_Names; +with Flags; +with PSL.Nodes; + +package body Errorout is + procedure Put (Str : String) + is + use Ada.Text_IO; + begin + Put (Standard_Error, Str); + end Put; + + procedure Put (C : Character) + is + use Ada.Text_IO; + begin + Put (Standard_Error, C); + end Put; + + procedure Put_Line (Str : String) + is + use Ada.Text_IO; + begin + Put_Line (Standard_Error, Str); + end Put_Line; + + procedure Disp_Natural (Val: Natural) + is + Str: constant String := Natural'Image (Val); + begin + 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 " + & Iir_Kind'Image (Get_Kind (An_Iir)) + & " (" & Disp_Location (An_Iir) & ')'); + raise Internal_Error; + end Error_Kind; + + procedure Error_Kind (Msg : String; Def : Iir_Predefined_Functions) is + begin + Put_Line (Msg & ": cannot handle " + & Iir_Predefined_Functions'Image (Def)); + raise Internal_Error; + end Error_Kind; + + procedure Error_Kind (Msg : String; N : PSL_Node) is + begin + Put (Msg); + Put (": cannot handle "); + Put_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N))); + 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 + Put (Name_Table.Image (File)); + Put (':'); + Disp_Natural (Line); + Put (':'); + Disp_Natural (Col); + Put (':'); + end Disp_Location; + + procedure Disp_Current_Location is + begin + Disp_Location (Scanner.Get_Current_File, + Scanner.Get_Current_Line, + Scanner.Get_Current_Column); + end Disp_Current_Location; + + procedure Disp_Token_Location is + begin + Disp_Location (Scanner.Get_Current_File, + Scanner.Get_Current_Line, + Scanner.Get_Token_Column); + end Disp_Token_Location; + + procedure Disp_Location (Loc : Location_Type) + is + Name : Name_Id; + Line : Natural; + Col : Natural; + begin + if Loc = Location_Nil then + -- Avoid a crash, but should not happen. + Put ("??:??:??:"); + else + Location_To_Position (Loc, Name, Line, Col); + Disp_Location (Name, Line, Col); + end if; + end Disp_Location; + + function Get_Location_Safe (N : Iir) return Location_Type is + begin + if N = Null_Iir then + return Location_Nil; + else + return Get_Location (N); + end if; + end Get_Location_Safe; + + procedure Disp_Iir_Location (An_Iir: Iir) is + begin + 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); + end Warning_Msg_Sem; + + procedure Warning_Msg_Sem (Msg: String; Loc : Iir) is + begin + Warning_Msg_Sem (Msg, Get_Location_Safe (Loc)); + end Warning_Msg_Sem; + + 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); + end Warning_Msg_Elab; + + procedure Warning_Msg_Elab (Msg: String; Loc : Iir) is + begin + 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); + 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); + 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); + 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); + 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); + 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); + 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); + end Error_Msg_Sem; + + procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) is + use PSL.Nodes; + begin + Nbr_Errors := Nbr_Errors + 1; + if Loc /= Null_Node then + Disp_PSL_Location (Loc); + Put (' '); + end if; + Put_Line (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); + end Error_Msg_Sem; + + -- Disp a message during elaboration. + procedure Error_Msg_Elab (Msg: String) is + begin + Nbr_Errors := Nbr_Errors + 1; + Put ("error: "); + Put_Line (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); + end Error_Msg_Elab; + + -- Disp a bug message. + procedure Error_Internal (Expr: in Iir; Msg: String := "") + is + pragma Unreferenced (Expr); + begin + Put ("internal error: "); + Put_Line (Msg); + raise Internal_Error; + end Error_Internal; + + function Disp_Label (Node : Iir; Str : String) return String + is + Id : Name_Id; + begin + Id := Get_Label (Node); + if Id = Null_Identifier then + return "(unlabeled) " & Str; + else + return Str & " labeled """ & Name_Table.Image (Id) & """"; + end if; + end Disp_Label; + + -- Disp a node. + -- Used for output of message. + function Disp_Node (Node: Iir) return String is + function Disp_Identifier (Node : Iir; Str : String) return String + is + Id : Name_Id; + begin + Id := Get_Identifier (Node); + return Str & " """ & Name_Table.Image (Id) & """"; + end Disp_Identifier; + + function Disp_Type (Node : Iir; Str : String) return String + is + Decl: Iir; + begin + Decl := Get_Type_Declarator (Node); + if Decl = Null_Iir then + return "the anonymous " & Str + & " defined at " & Disp_Location (Node); + else + return Disp_Identifier (Decl, Str); + end if; + end Disp_Type; + + begin + case Get_Kind (Node) is + when Iir_Kind_String_Literal => + return "string literal """ + & Image_String_Lit (Node) & """"; + when Iir_Kind_Bit_String_Literal => + return "bit string literal """ + & Image_String_Lit (Node) & """"; + when Iir_Kind_Character_Literal => + return "character literal " & Image_Identifier (Node); + when Iir_Kind_Integer_Literal => + return "integer literal"; + when Iir_Kind_Floating_Point_Literal => + return "floating point literal"; + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return "physical literal"; + when Iir_Kind_Enumeration_Literal => + return "enumeration literal " & Image_Identifier (Node); + when Iir_Kind_Element_Declaration => + return Disp_Identifier (Node, "element"); + when Iir_Kind_Record_Element_Constraint => + return "record element constraint"; + when Iir_Kind_Array_Element_Resolution => + return "array element resolution"; + when Iir_Kind_Record_Resolution => + return "record resolution"; + when Iir_Kind_Record_Element_Resolution => + return "record element resolution"; + when Iir_Kind_Null_Literal => + return "null literal"; + when Iir_Kind_Overflow_Literal => + return Disp_Node (Get_Literal_Origin (Node)); + when Iir_Kind_Aggregate => + return "aggregate"; + when Iir_Kind_Unit_Declaration => + return Disp_Identifier (Node, "physical unit"); + when Iir_Kind_Simple_Aggregate => + return "locally static array literal"; + + when Iir_Kind_Operator_Symbol => + return "operator name"; + when Iir_Kind_Aggregate_Info => + return "aggregate info"; + when Iir_Kind_Signature => + return "signature"; + when Iir_Kind_Waveform_Element => + return "waveform element"; + when Iir_Kind_Conditional_Waveform => + return "conditional waveform"; + when Iir_Kind_Association_Element_Open => + return "open association element"; + when Iir_Kind_Association_Element_By_Individual => + return "individual association element"; + when Iir_Kind_Association_Element_By_Expression + | Iir_Kind_Association_Element_Package => + return "association element"; + when Iir_Kind_Overload_List => + return "overloaded name or expression"; + + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Enumeration_Type_Definition => + return Image_Identifier (Get_Type_Declarator (Node)); + when Iir_Kind_Array_Type_Definition => + return Disp_Type (Node, "array type"); + when Iir_Kind_Array_Subtype_Definition => + return Disp_Type (Node, "array subtype"); + when Iir_Kind_Record_Type_Definition => + return Disp_Type (Node, "record type"); + when Iir_Kind_Record_Subtype_Definition => + return Disp_Type (Node, "record subtype"); + when Iir_Kind_Enumeration_Subtype_Definition => + return Disp_Type (Node, "enumeration subtype"); + when Iir_Kind_Integer_Subtype_Definition => + return Disp_Type (Node, "integer subtype"); + when Iir_Kind_Physical_Type_Definition => + return Disp_Type (Node, "physical type"); + when Iir_Kind_Physical_Subtype_Definition => + return Disp_Type (Node, "physical subtype"); + when Iir_Kind_File_Type_Definition => + return Disp_Type (Node, "file type"); + when Iir_Kind_Access_Type_Definition => + return Disp_Type (Node, "access type"); + when Iir_Kind_Access_Subtype_Definition => + return Disp_Type (Node, "access subtype"); + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Disp_Type (Node, "floating type"); + when Iir_Kind_Incomplete_Type_Definition => + return Disp_Type (Node, "incomplete type"); + when Iir_Kind_Protected_Type_Declaration => + return Disp_Type (Node, "protected type"); + when Iir_Kind_Protected_Type_Body => + return Disp_Type (Node, "protected type body"); + when Iir_Kind_Subtype_Definition => + return "subtype definition"; + + when Iir_Kind_Scalar_Nature_Definition => + return Image_Identifier (Get_Nature_Declarator (Node)); + + when Iir_Kind_Choice_By_Expression => + return "choice by expression"; + when Iir_Kind_Choice_By_Range => + return "choice by range"; + when Iir_Kind_Choice_By_Name => + return "choice by name"; + when Iir_Kind_Choice_By_Others => + return "others choice"; + when Iir_Kind_Choice_By_None => + return "positionnal choice"; + + when Iir_Kind_Function_Call => + return "function call"; + when Iir_Kind_Procedure_Call_Statement => + return "procedure call statement"; + when Iir_Kind_Procedure_Call => + return "procedure call"; + when Iir_Kind_Selected_Name => + Name_Table.Image (Get_Identifier (Node)); + return ''' + & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length) + & '''; + when Iir_Kind_Simple_Name => + Name_Table.Image (Get_Identifier (Node)); + return ''' + & Name_Table.Name_Buffer (1 .. Name_Table.Name_Length) + & '''; + when Iir_Kind_Entity_Aspect_Entity => + return "aspect " & Disp_Node (Get_Entity (Node)) + & '(' & Image_Identifier (Get_Architecture (Node)) & ')'; + when Iir_Kind_Entity_Aspect_Configuration => + return "configuration entity aspect"; + when Iir_Kind_Entity_Aspect_Open => + return "open entity aspect"; + + when Iir_Kinds_Monadic_Operator + | Iir_Kinds_Dyadic_Operator => + return "operator """ + & Name_Table.Image (Get_Operator_Name (Node)) & """"; + when Iir_Kind_Parenthesis_Expression => + return "expression"; + when Iir_Kind_Qualified_Expression => + return "qualified expression"; + when Iir_Kind_Type_Conversion => + return "type conversion"; + when Iir_Kind_Allocator_By_Subtype + | Iir_Kind_Allocator_By_Expression => + return "allocator"; + when Iir_Kind_Indexed_Name => + return "indexed name"; + when Iir_Kind_Range_Expression => + return "range expression"; + when Iir_Kind_Implicit_Dereference => + return "implicit access dereference"; + when Iir_Kind_Dereference => + return "access dereference"; + when Iir_Kind_Selected_Element => + return "selected element"; + when Iir_Kind_Selected_By_All_Name => + return ".all name"; + when Iir_Kind_Psl_Expression => + return "PSL instantiation"; + + when Iir_Kind_Interface_Constant_Declaration => + if Get_Parent (Node) = Null_Iir then + -- For constant interface of predefined operator. + return "anonymous interface"; + end if; + case Get_Kind (Get_Parent (Node)) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Block_Header => + return Disp_Identifier (Node, "generic"); + when others => + return Disp_Identifier (Node, "constant interface"); + end case; + when Iir_Kind_Interface_Signal_Declaration => + case Get_Kind (Get_Parent (Node)) is + when Iir_Kind_Entity_Declaration + | Iir_Kind_Block_Statement + | Iir_Kind_Block_Header => + return Disp_Identifier (Node, "port"); + when others => + return Disp_Identifier (Node, "signal interface"); + end case; + when Iir_Kind_Interface_Variable_Declaration => + return Disp_Identifier (Node, "variable interface"); + when Iir_Kind_Interface_File_Declaration => + return Disp_Identifier (Node, "file interface"); + when Iir_Kind_Interface_Package_Declaration => + return Disp_Identifier (Node, "package interface"); + when Iir_Kind_Signal_Declaration => + return Disp_Identifier (Node, "signal"); + when Iir_Kind_Variable_Declaration => + return Disp_Identifier (Node, "variable"); + when Iir_Kind_Iterator_Declaration + | Iir_Kind_Constant_Declaration => + return Disp_Identifier (Node, "constant"); + when Iir_Kind_File_Declaration => + return Disp_Identifier (Node, "file"); + when Iir_Kind_Object_Alias_Declaration => + return Disp_Identifier (Node, "alias"); + when Iir_Kind_Non_Object_Alias_Declaration => + return Disp_Identifier (Node, "non-object alias"); + when Iir_Kind_Guard_Signal_Declaration => + return "GUARD signal"; + when Iir_Kind_Group_Template_Declaration => + return Disp_Identifier (Node, "group template"); + when Iir_Kind_Group_Declaration => + return Disp_Identifier (Node, "group"); + + when Iir_Kind_Library_Declaration + | Iir_Kind_Library_Clause => + return Disp_Identifier (Node, "library"); + when Iir_Kind_Design_File => + return "design file"; + + when Iir_Kind_Procedure_Declaration => + return Disp_Identifier (Node, "procedure"); + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + return "subprogram body"; + when Iir_Kind_Function_Declaration => + return Disp_Identifier (Node, "function"); + + when Iir_Kind_Package_Declaration => + return Disp_Identifier (Node, "package"); + when Iir_Kind_Package_Body => + return Disp_Identifier (Node, "package body"); + when Iir_Kind_Entity_Declaration => + return Disp_Identifier (Node, "entity"); + when Iir_Kind_Architecture_Body => + return Disp_Identifier (Node, "architecture") & + " of" & Disp_Identifier (Get_Entity_Name (Node), ""); + when Iir_Kind_Configuration_Declaration => + declare + Id : Name_Id; + Ent : Iir; + Arch : Iir; + begin + Id := Get_Identifier (Node); + if Id /= Null_Identifier then + return Disp_Identifier (Node, "configuration"); + else + Ent := Get_Entity (Node); + Arch := Get_Block_Specification + (Get_Block_Configuration (Node)); + return "default configuration of " + & Image_Identifier (Ent) + & '(' & Image_Identifier (Arch) & ')'; + end if; + end; + when Iir_Kind_Package_Instantiation_Declaration => + return Disp_Identifier (Node, "instantiation package"); + + when Iir_Kind_Package_Header => + return "package header"; + + when Iir_Kind_Component_Declaration => + return Disp_Identifier (Node, "component"); + + when Iir_Kind_Design_Unit => + return Disp_Node (Get_Library_Unit (Node)); + when Iir_Kind_Use_Clause => + return "use clause"; + when Iir_Kind_Disconnection_Specification => + return "disconnection specification"; + + when Iir_Kind_Slice_Name => + return "slice"; + when Iir_Kind_Parenthesis_Name => + return "function call, slice or indexed name"; + when Iir_Kind_Type_Declaration => + return Disp_Identifier (Node, "type"); + when Iir_Kind_Anonymous_Type_Declaration => + return Disp_Identifier (Node, "type"); + when Iir_Kind_Subtype_Declaration => + return Disp_Identifier (Node, "subtype"); + + when Iir_Kind_Nature_Declaration => + return Disp_Identifier (Node, "nature"); + when Iir_Kind_Subnature_Declaration => + return Disp_Identifier (Node, "subnature"); + + when Iir_Kind_Component_Instantiation_Statement => + return Disp_Identifier (Node, "component instance"); + when Iir_Kind_Configuration_Specification => + return "configuration specification"; + when Iir_Kind_Component_Configuration => + return "component configuration"; + when Iir_Kind_Implicit_Function_Declaration => + return Disp_Identifier (Node, "implicit function") + & Disp_Identifier (Get_Type_Reference (Node), " of type"); +-- return "implicit function " +-- & Get_Predefined_Function_Name +-- (Get_Implicit_Definition (Node)); + when Iir_Kind_Implicit_Procedure_Declaration => + return "implicit procedure " + & Get_Predefined_Function_Name (Get_Implicit_Definition (Node)); + + when Iir_Kind_Concurrent_Procedure_Call_Statement => + return "concurrent procedure call"; + when Iir_Kind_Generate_Statement => + return "generate statement"; + + when Iir_Kind_Simple_Simultaneous_Statement => + return "simple simultaneous statement"; + + when Iir_Kind_Psl_Declaration => + return Disp_Identifier (Node, "PSL declaration"); + + when Iir_Kind_Terminal_Declaration => + return Disp_Identifier (Node, "terminal declaration"); + when Iir_Kind_Free_Quantity_Declaration + | Iir_Kind_Across_Quantity_Declaration + | Iir_Kind_Through_Quantity_Declaration => + return Disp_Identifier (Node, "quantity declaration"); + + when Iir_Kind_Attribute_Declaration => + return Disp_Identifier (Node, "attribute"); + when Iir_Kind_Attribute_Specification => + return "attribute specification"; + when Iir_Kind_Entity_Class => + return "entity class"; + when Iir_Kind_Attribute_Value => + return "attribute value"; + when Iir_Kind_Attribute_Name => + return "attribute"; + when Iir_Kind_Base_Attribute => + return "'base attribute"; + when Iir_Kind_Length_Array_Attribute => + return "'length attribute"; + when Iir_Kind_Range_Array_Attribute => + return "'range attribute"; + when Iir_Kind_Reverse_Range_Array_Attribute => + return "'reverse_range attribute"; + when Iir_Kind_Ascending_Type_Attribute + | Iir_Kind_Ascending_Array_Attribute => + return "'ascending attribute"; + when Iir_Kind_Left_Type_Attribute + | Iir_Kind_Left_Array_Attribute => + return "'left attribute"; + when Iir_Kind_Right_Type_Attribute + | Iir_Kind_Right_Array_Attribute => + return "'right attribute"; + when Iir_Kind_Low_Type_Attribute + | Iir_Kind_Low_Array_Attribute => + return "'low attribute"; + when Iir_Kind_Leftof_Attribute => + return "'leftof attribute"; + when Iir_Kind_Rightof_Attribute => + return "'rightof attribute"; + when Iir_Kind_Pred_Attribute => + return "'pred attribute"; + when Iir_Kind_Succ_Attribute => + return "'succ attribute"; + when Iir_Kind_Pos_Attribute => + return "'pos attribute"; + when Iir_Kind_Val_Attribute => + return "'val attribute"; + when Iir_Kind_Image_Attribute => + return "'image attribute"; + when Iir_Kind_Value_Attribute => + return "'value attribute"; + when Iir_Kind_High_Type_Attribute + | Iir_Kind_High_Array_Attribute => + return "'high attribute"; + when Iir_Kind_Transaction_Attribute => + return "'transaction attribute"; + when Iir_Kind_Stable_Attribute => + return "'stable attribute"; + when Iir_Kind_Quiet_Attribute => + return "'quiet attribute"; + when Iir_Kind_Delayed_Attribute => + return "'delayed attribute"; + when Iir_Kind_Driving_Attribute => + return "'driving attribute"; + when Iir_Kind_Driving_Value_Attribute => + return "'driving_value attribute"; + when Iir_Kind_Event_Attribute => + return "'event attribute"; + when Iir_Kind_Active_Attribute => + return "'active attribute"; + when Iir_Kind_Last_Event_Attribute => + return "'last_event attribute"; + when Iir_Kind_Last_Active_Attribute => + return "'last_active attribute"; + when Iir_Kind_Last_Value_Attribute => + return "'last_value attribute"; + when Iir_Kind_Behavior_Attribute => + return "'behavior attribute"; + when Iir_Kind_Structure_Attribute => + return "'structure attribute"; + + when Iir_Kind_Path_Name_Attribute => + return "'path_name attribute"; + when Iir_Kind_Instance_Name_Attribute => + return "'instance_name attribute"; + when Iir_Kind_Simple_Name_Attribute => + return "'simple_name attribute"; + + when Iir_Kind_For_Loop_Statement => + return Disp_Label (Node, "for loop statement"); + when Iir_Kind_While_Loop_Statement => + return Disp_Label (Node, "loop statement"); + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + return Disp_Label (Node, "process"); + when Iir_Kind_Block_Statement => + return Disp_Label (Node, "block statement"); + when Iir_Kind_Block_Header => + return "block header"; + when Iir_Kind_Concurrent_Conditional_Signal_Assignment => + return Disp_Label + (Node, "concurrent conditional signal assignment"); + when Iir_Kind_Concurrent_Selected_Signal_Assignment => + return Disp_Label + (Node, "concurrent selected signal assignment"); + when Iir_Kind_Concurrent_Assertion_Statement => + return Disp_Label (Node, "concurrent assertion"); + when Iir_Kind_Psl_Assert_Statement => + return Disp_Label (Node, "PSL assertion"); + when Iir_Kind_Psl_Cover_Statement => + return Disp_Label (Node, "PSL cover"); + when Iir_Kind_Psl_Default_Clock => + return "PSL default clock"; + + when Iir_Kind_If_Statement => + return Disp_Label (Node, "if statement"); + when Iir_Kind_Elsif => + return Disp_Label (Node, "else/elsif statement"); + when Iir_Kind_Next_Statement => + return Disp_Label (Node, "next statement"); + when Iir_Kind_Exit_Statement => + return Disp_Label (Node, "exit statement"); + when Iir_Kind_Case_Statement => + return Disp_Label (Node, "case statement"); + when Iir_Kind_Return_Statement => + return Disp_Label (Node, "return statement"); + when Iir_Kind_Signal_Assignment_Statement => + return Disp_Label (Node, "signal assignment statement"); + when Iir_Kind_Variable_Assignment_Statement => + return Disp_Label (Node, "variable assignment statement"); + when Iir_Kind_Null_Statement => + return Disp_Label (Node, "null statement"); + when Iir_Kind_Wait_Statement => + return Disp_Label (Node, "wait statement"); + when Iir_Kind_Assertion_Statement => + return Disp_Label (Node, "assertion statement"); + when Iir_Kind_Report_Statement => + return Disp_Label (Node, "report statement"); + + when Iir_Kind_Block_Configuration => + return "block configuration"; + when Iir_Kind_Binding_Indication => + return "binding indication"; + + when Iir_Kind_Error => + return "error"; + when Iir_Kind_Unused => + return "*unused*"; + end case; + end Disp_Node; + + -- Disp a node location. + -- Used for output of message. + + function Get_Location_Str + (Name : Name_Id; Line, Col : Natural; Filename : Boolean) + return String + is + Line_Str : constant String := Natural'Image (Line); + Col_Str : constant String := Natural'Image (Col); + begin + if Filename then + return Name_Table.Image (Name) + & ':' & Line_Str (Line_Str'First + 1 .. Line_Str'Last) + & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); + else + return Line_Str (Line_Str'First + 1 .. Line_Str'Last) + & ':' & Col_Str (Col_Str'First + 1 .. Col_Str'Last); + end if; + end Get_Location_Str; + + function Get_Location_Str (Loc : Location_Type; Filename : Boolean := True) + return string + is + Line, Col : Natural; + Name : Name_Id; + begin + if Loc = Location_Nil then + -- Avoid a crash. + return "??:??:??"; + else + Location_To_Position (Loc, Name, Line, Col); + return Get_Location_Str (Name, Line, Col, Filename); + end if; + end Get_Location_Str; + + function Disp_Location (Node: Iir) return String is + begin + return Get_Location_Str (Get_Location (Node)); + end Disp_Location; + + function Disp_Name (Kind : Iir_Kind) return String is + begin + case Kind is + when Iir_Kind_Constant_Declaration => + return "constant declaration"; + when Iir_Kind_Signal_Declaration => + return "signal declaration"; + when Iir_Kind_Variable_Declaration => + return "variable declaration"; + when Iir_Kind_File_Declaration => + return "file declaration"; + when others => + return "???" & Iir_Kind'Image (Kind); + end case; + end Disp_Name; + + function Image (N : Iir_Int64) return String + is + Res : constant String := Iir_Int64'Image (N); + begin + if Res (1) = ' ' then + return Res (2 .. Res'Last); + else + return Res; + end if; + end Image; + + function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String is + begin + case Get_Kind (Dtype) is + when Iir_Kind_Integer_Type_Definition => + return Image (Pos); + when Iir_Kind_Enumeration_Type_Definition => + return Name_Table.Image + (Get_Identifier (Get_Nth_Element + (Get_Enumeration_Literal_List (Dtype), + Natural (Pos)))); + when others => + Error_Kind ("disp_discrete", Dtype); + end case; + end Disp_Discrete; + + function Disp_Subprg (Subprg : Iir) return String + is + use Ada.Strings.Unbounded; + Res : Unbounded_String; + + procedure Append_Type (Def : Iir) + is + use Name_Table; + Decl : Iir := Get_Type_Declarator (Def); + begin + if Decl = Null_Iir then + Decl := Get_Type_Declarator (Get_Base_Type (Def)); + end if; + Image (Get_Identifier (Decl)); + Append (Res, Name_Buffer (1 .. Name_Length)); + end Append_Type; + + begin + case Get_Kind (Subprg) is + when Iir_Kind_Enumeration_Literal => + Append (Res, "enumeration literal "); + when Iir_Kind_Implicit_Function_Declaration => + Append (Res, "implicit function "); + when Iir_Kind_Implicit_Procedure_Declaration => + Append (Res, "implicit procedure "); + when Iir_Kind_Function_Declaration => + Append (Res, "function "); + when Iir_Kind_Procedure_Declaration => + Append (Res, "procedure "); + when others => + Error_Kind ("disp_subprg", Subprg); + end case; + + declare + use Name_Table; + + Id : constant Name_Id := Get_Identifier (Subprg); + begin + Image (Id); + case Id is + when Std_Names.Name_Id_Operators + | Std_Names.Name_Word_Operators + | Std_Names.Name_Xnor + | Std_Names.Name_Shift_Operators => + Append (Res, """"); + Append (Res, Name_Buffer (1 .. Name_Length)); + Append (Res, """"); + when others => + Append (Res, Name_Buffer (1 .. Name_Length)); + end case; + end; + + Append (Res, " ["); + + case Get_Kind (Subprg) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Implicit_Procedure_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + declare + El : Iir; + begin + El := Get_Interface_Declaration_Chain (Subprg); + while El /= Null_Iir loop + Append_Type (Get_Type (El)); + El := Get_Chain (El); + exit when El = Null_Iir; + Append (Res, ", "); + end loop; + end; + when others => + null; + end case; + + case Get_Kind (Subprg) is + when Iir_Kind_Implicit_Function_Declaration + | Iir_Kind_Function_Declaration + | Iir_Kind_Enumeration_Literal => + Append (Res, " return "); + Append_Type (Get_Return_Type (Subprg)); + when others => + null; + end case; + + Append (Res, "]"); + + return To_String (Res); + end Disp_Subprg; + + -- DEF must be any type definition. + -- Return the type name of DEF, handle anonymous subtypes. + function Disp_Type_Name (Def : Iir) return String + is + Decl : Iir; + begin + Decl := Get_Type_Declarator (Def); + if Decl /= Null_Iir then + return Image_Identifier (Decl); + end if; + Decl := Get_Type_Declarator (Get_Base_Type (Def)); + if Decl /= Null_Iir then + return "a subtype of " & Image_Identifier (Decl); + else + return "an unknown type"; + end if; + end Disp_Type_Name; + + function Disp_Type_Of (Node : Iir) return String + is + A_Type : Iir; + begin + A_Type := Get_Type (Node); + if A_Type = Null_Iir then + return "unknown"; + elsif Get_Kind (A_Type) = Iir_Kind_Overload_List then + declare + use Ada.Strings.Unbounded; + Res : Unbounded_String; + List : Iir_List; + El : Iir; + Nbr : Natural; + begin + List := Get_Overload_List (A_Type); + Nbr := Get_Nbr_Elements (List); + if Nbr = 0 then + return "unknown"; + elsif Nbr = 1 then + return Disp_Type_Name (Get_First_Element (List)); + else + Append (Res, "one of "); + for I in 0 .. Nbr - 1 loop + El := Get_Nth_Element (List, I); + Append (Res, Disp_Type_Name (El)); + if I < Nbr - 2 then + Append (Res, ", "); + elsif I = Nbr - 2 then + Append (Res, " or "); + end if; + end loop; + return To_String (Res); + end if; + end; + else + return Disp_Type_Name (A_Type); + end if; + end Disp_Type_Of; + + procedure Error_Pure (Caller : Iir; Callee : Iir; Loc : Iir) + is + L : Location_Type; + begin + if Loc = Null_Iir then + L := Get_Location (Caller); + else + L := Get_Location (Loc); + end if; + Error_Msg_Sem + ("pure " & Disp_Node (Caller) & " cannot call (impure) " + & Disp_Node (Callee), L); + Error_Msg_Sem + ("(" & Disp_Node (Callee) & " is defined here)", Callee); + end Error_Pure; + + procedure Error_Not_Match (Expr: Iir; A_Type: Iir; Loc : Iir) + is + begin + Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type " + & Disp_Node (A_Type), Loc); + if Loc /= Expr then + Error_Msg_Sem ("(location of " & Disp_Node (Expr) & ")", Expr); + end if; + end Error_Not_Match; + + function Get_Mode_Name (Mode : Iir_Mode) return String is + begin + case Mode is + when Iir_Unknown_Mode => + raise Internal_Error; + when Iir_Linkage_Mode => + return "linkage"; + when Iir_Buffer_Mode => + return "buffer"; + when Iir_Out_Mode => + return "out"; + when Iir_Inout_Mode => + return "inout"; + when Iir_In_Mode => + return "in"; + end case; + end Get_Mode_Name; + +end Errorout; |