diff options
| author | Tristan Gingold <tgingold@free.fr> | 2019-05-08 07:33:04 +0200 | 
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2019-05-08 07:33:04 +0200 | 
| commit | a05c5813bee6c063dc196471e66816fbca5dc50e (patch) | |
| tree | 7e6e01af2cbb3bcb02bf52fab6bf3075e613a211 | |
| parent | d87e8284e3dc3adced8b8aa2258e3a87097396b1 (diff) | |
| download | ghdl-a05c5813bee6c063dc196471e66816fbca5dc50e.tar.gz ghdl-a05c5813bee6c063dc196471e66816fbca5dc50e.tar.bz2 ghdl-a05c5813bee6c063dc196471e66816fbca5dc50e.zip | |
vhdl: extract vhdl.errors from errorout.
62 files changed, 1198 insertions, 1101 deletions
| diff --git a/src/ghdldrv/ghdlprint.adb b/src/ghdldrv/ghdlprint.adb index 73f386f4a..3addfbfe3 100644 --- a/src/ghdldrv/ghdlprint.adb +++ b/src/ghdldrv/ghdlprint.adb @@ -26,6 +26,7 @@ with Name_Table; use Name_Table;  with Files_Map;  with Libraries;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Tokens;  with Vhdl.Scanner; diff --git a/src/ghdldrv/ghdlrun.adb b/src/ghdldrv/ghdlrun.adb index 9ae929efe..5cf5ca4dd 100644 --- a/src/ghdldrv/ghdlrun.adb +++ b/src/ghdldrv/ghdlrun.adb @@ -35,6 +35,7 @@ with Vhdl.Nodes; use Vhdl.Nodes;  with Vhdl.Std_Package;  with Flags;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Libraries;  with Vhdl.Canon;  with Vhdl.Configuration; diff --git a/src/libraries.adb b/src/libraries.adb index 0f552e911..0540c709e 100644 --- a/src/libraries.adb +++ b/src/libraries.adb @@ -21,6 +21,7 @@ with GNAT.OS_Lib;  with Logging; use Logging;  with Tables;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Scanner;  with Vhdl.Utils; use Vhdl.Utils;  with Name_Table; use Name_Table; diff --git a/src/synth/synth-context.adb b/src/synth/synth-context.adb index a84f56e38..135b40d7c 100644 --- a/src/synth/synth-context.adb +++ b/src/synth/synth-context.adb @@ -22,7 +22,7 @@ with Ada.Unchecked_Deallocation;  with Types; use Types;  with Grt.Types; use Grt.Types; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils;  with Vhdl.Std_Package; diff --git a/src/synth/synth-decls.adb b/src/synth/synth-decls.adb index 23e34b957..576a90918 100644 --- a/src/synth/synth-decls.adb +++ b/src/synth/synth-decls.adb @@ -21,7 +21,7 @@  with Types; use Types;  with Netlists; use Netlists;  with Netlists.Builders; use Netlists.Builders; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Synth.Context; use Synth.Context;  with Synth.Types; use Synth.Types;  with Synth.Environment; use Synth.Environment; diff --git a/src/synth/synth-expr.adb b/src/synth/synth-expr.adb index 7a682dbff..0384aa785 100644 --- a/src/synth/synth-expr.adb +++ b/src/synth/synth-expr.adb @@ -23,7 +23,7 @@ with Ada.Unchecked_Deallocation;  with Std_Names;  with Vhdl.Ieee.Std_Logic_1164;  with Vhdl.Std_Package; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Simul.Execution;  with Grt.Types; use Grt.Types; diff --git a/src/synth/synth-stmts.adb b/src/synth/synth-stmts.adb index 613bcdbdd..99021984a 100644 --- a/src/synth/synth-stmts.adb +++ b/src/synth/synth-stmts.adb @@ -23,7 +23,7 @@ with Ada.Unchecked_Deallocation;  with Types; use Types;  with Grt.Algos;  with Areapools; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Sem_Expr;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/synth/synth-types.adb b/src/synth/synth-types.adb index 19e9677ec..cc89eefe3 100644 --- a/src/synth/synth-types.adb +++ b/src/synth/synth-types.adb @@ -25,7 +25,7 @@ with Vhdl.Utils; use Vhdl.Utils;  with Simul.Environments; use Simul.Environments;  with Simul.Execution; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  package body Synth.Types is     function Is_Bit_Type (Atype : Iir) return Boolean is diff --git a/src/synth/synthesis.adb b/src/synth/synthesis.adb index 770fb52c9..4a346b0a9 100644 --- a/src/synth/synthesis.adb +++ b/src/synth/synthesis.adb @@ -39,6 +39,7 @@ with Synth.Environment.Debug;  pragma Unreferenced (Synth.Environment.Debug);  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  package body Synthesis is     function Mode_To_Port_Kind (Mode : Iir_Mode) return Port_Kind is diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb index 2dd867246..1b022391d 100644 --- a/src/vhdl/errorout.adb +++ b/src/vhdl/errorout.adb @@ -19,30 +19,14 @@  with Logging; use Logging;  with Vhdl.Scanner;  with Name_Table; -with Vhdl.Utils; use Vhdl.Utils;  with Files_Map; use Files_Map; -with Ada.Strings.Unbounded; -with Std_Names;  with Flags; use Flags;  with PSL.Nodes;  with Str_Table; -package body Errorout is -   procedure Error_Kind (Msg : String; An_Iir : Iir) is -   begin -      Log_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 -      Log_Line -        (Msg & ": cannot handle " & Iir_Predefined_Functions'Image (Def)); -      raise Internal_Error; -   end Error_Kind; +with Vhdl.Errors; use Vhdl.Errors; +package body Errorout is     procedure Error_Kind (Msg : String; N : PSL_Node) is     begin        Log (Msg); @@ -132,11 +116,6 @@ package body Errorout is     --  Error arguments -   function "+" (V : Iir) return Earg_Type is -   begin -      return (Kind => Earg_Iir, Val_Iir => V); -   end "+"; -     function "+" (V : Location_Type) return Earg_Type is     begin        return (Kind => Earg_Location, Val_Loc => V); @@ -147,11 +126,6 @@ package body Errorout is        return (Kind => Earg_Id, Val_Id => V);     end "+"; -   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type is -   begin -      return (Kind => Earg_Token, Val_Tok => V); -   end "+"; -     function "+" (V : Character) return Earg_Type is     begin        return (Kind => Earg_Char, Val_Char => V); @@ -162,17 +136,6 @@ package body Errorout is        return (Kind => Earg_String8, Val_Str8 => V);     end "+"; -   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; - -   function "+" (L : Iir) return Location_Type renames Get_Location_Safe; -     function "+" (L : PSL_Node) return Location_Type     is        use PSL.Nodes; @@ -459,940 +422,16 @@ package body Errorout is        Report_Msg (Id, Option, No_Location, Msg);     end Warning_Msg_Option; -   procedure Warning_Msg_Sem (Id : Msgid_Warnings; -                              Loc : Location_Type; -                              Msg: String; -                              Args : Earg_Arr := No_Eargs; -                              Cont : Boolean := False) is -   begin -      if Flags.Flag_Only_Elab_Warnings then -         return; -      end if; -      Report_Msg (Id, Semantic, Loc, Msg, Args, Cont); -   end Warning_Msg_Sem; - -   procedure Warning_Msg_Sem (Id : Msgid_Warnings; -                              Loc : Location_Type; -                              Msg: String; -                              Arg1 : Earg_Type; -                              Cont : Boolean := False) is -   begin -      Warning_Msg_Sem (Id, Loc, Msg, Earg_Arr'(1 => Arg1), Cont); -   end Warning_Msg_Sem; - -   procedure Warning_Msg_Elab (Id : Msgid_Warnings; -                               Loc : Iir; -                               Msg: String; -                               Arg1 : Earg_Type; -                               Cont : Boolean := False) is -   begin -      Report_Msg (Id, Elaboration, +Loc, Msg, Earg_Arr'(1 => Arg1), Cont); -   end Warning_Msg_Elab; - -   procedure Warning_Msg_Elab (Id : Msgid_Warnings; -                               Loc : Iir; -                               Msg: String; -                               Args : Earg_Arr := No_Eargs; -                               Cont : Boolean := False) is -   begin -      Report_Msg (Id, Elaboration, +Loc, Msg, Args, Cont); -   end Warning_Msg_Elab; - -   -- 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 (Msgid_Error, Semantic, Get_Location_Safe (Loc), Msg); -   end Error_Msg_Sem; - -   procedure Error_Msg_Sem (Loc: Location_Type; -                            Msg: String; -                            Args : Earg_Arr := No_Eargs; -                            Cont : Boolean := False) is -   begin -      Report_Msg (Msgid_Error, Semantic, Loc, Msg, Args, Cont); -   end Error_Msg_Sem; - -   procedure Error_Msg_Sem -     (Loc: Location_Type; Msg: String; Arg1 : Earg_Type) is -   begin -      Report_Msg (Msgid_Error, Semantic, Loc, Msg, (1 => Arg1)); -   end Error_Msg_Sem; - -   procedure Error_Msg_Sem_1 (Msg: String; Loc : PSL_Node) is -   begin -      Error_Msg_Sem (+Loc, Msg); -   end Error_Msg_Sem_1; - -   procedure Error_Msg_Relaxed (Origin : Report_Origin; -                                Id : Msgid_Warnings; -                                Msg : String; -                                Loc : Iir; -                                Args : Earg_Arr := No_Eargs) -   is -      Level : Msgid_Type; -   begin -      if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then -         if not Is_Warning_Enabled (Id) then -            return; -         end if; -         Level := Id; -      else -         Level := Msgid_Error; -      end if; -      Report_Msg (Level, Origin, Get_Location_Safe (Loc), Msg, Args); -   end Error_Msg_Relaxed; - -   procedure Error_Msg_Sem_Relaxed (Loc : Iir; -                                    Id : Msgid_Warnings; -                                    Msg : String; -                                    Args : Earg_Arr := No_Eargs) is -   begin -      Error_Msg_Relaxed (Semantic, Id, Msg, Loc, Args); -   end Error_Msg_Sem_Relaxed; - -   -- Disp a message during elaboration. -   procedure Error_Msg_Elab -     (Msg: String; Args : Earg_Arr := No_Eargs) is -   begin -      Report_Msg (Msgid_Error, Elaboration, No_Location, Msg, Args); -   end Error_Msg_Elab; - -   procedure Error_Msg_Elab -     (Msg: String; Arg1 : Earg_Type) is -   begin -      Error_Msg_Elab (Msg, Earg_Arr'(1 => Arg1)); -   end Error_Msg_Elab; - -   procedure Error_Msg_Elab -     (Loc: Iir; Msg: String; Args : Earg_Arr := No_Eargs) is -   begin -      Report_Msg (Msgid_Error, Elaboration, +Loc, Msg, Args); -   end Error_Msg_Elab; - -   procedure Error_Msg_Elab -     (Loc: Iir; Msg: String; Arg1 : Earg_Type) is -   begin -      Error_Msg_Elab (Loc, Msg, Earg_Arr'(1 => Arg1)); -   end Error_Msg_Elab; - -   procedure Error_Msg_Elab_Relaxed (Loc : Iir; -                                     Id : Msgid_Warnings; -                                     Msg : String; -                                     Args : Earg_Arr := No_Eargs) is -   begin -      Error_Msg_Relaxed (Elaboration, Id, Msg, Loc, Args); -   end Error_Msg_Elab_Relaxed; - -   -- Disp a bug message. -   procedure Error_Internal (Expr: in Iir; Msg: String := "") -   is -      pragma Unreferenced (Expr); -   begin -      Log ("internal error: "); -      Log_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 "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_Literal8 => -            return "string literal"; -         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_Unaffected_Waveform => -            return "unaffected waveform"; -         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_Conditional_Expression => -            return "conditional expression"; -         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 -           | Iir_Kind_Association_Element_Type -            | Iir_Kind_Association_Element_Subprogram => -            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_Wildcard_Type_Definition => -            return "<any>"; -         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_Interface_Type_Definition => -            return Disp_Type (Node, "interface 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 => -            return ''' & Name_Table.Image (Get_Identifier (Node)) & '''; -         when Iir_Kind_Simple_Name => -            return ''' & Name_Table.Image (Get_Identifier (Node)) & '''; -         when Iir_Kind_Reference_Name => -            --  Shouldn't happen. -            return "name"; -         when Iir_Kind_External_Constant_Name => -            return "external constant name"; -         when Iir_Kind_External_Signal_Name => -            return "external signal name"; -         when Iir_Kind_External_Variable_Name => -            return "external variable name"; - -         when Iir_Kind_Package_Pathname => -            return "package pathname"; -         when Iir_Kind_Absolute_Pathname => -            return "absolute pathname"; -         when Iir_Kind_Relative_Pathname => -            return "relative pathname"; -         when Iir_Kind_Pathname_Element => -            return "pathname element"; - -         when Iir_Kind_Entity_Aspect_Entity => -            declare -               Arch : constant Iir := Get_Architecture (Node); -               Ent : constant Iir := Get_Entity (Node); -            begin -               if Arch = Null_Iir then -                  return "aspect " & Disp_Node (Ent); -               else -                  return "aspect " & Disp_Node (Ent) -                    & '(' & Image_Identifier (Arch) & ')'; -               end if; -            end; -         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_Interface_Type_Declaration => -            return Disp_Identifier (Node, "type 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_Signal_Attribute_Declaration => -            --  Should not appear. -            return "signal attribute"; -         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_Function_Declaration => -            return Disp_Identifier (Node, "function"); -         when Iir_Kind_Interface_Procedure_Declaration => -            return Disp_Identifier (Node, "interface procedure"); -         when Iir_Kind_Interface_Function_Declaration => -            return Disp_Identifier (Node, "interface function"); -         when Iir_Kind_Procedure_Body -           | Iir_Kind_Function_Body => -            return "subprogram body"; - -         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_Context_Declaration => -            return Disp_Identifier (Node, "context"); -         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_Context_Reference => -            return "context reference"; -         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_Concurrent_Procedure_Call_Statement => -            return "concurrent procedure call"; -         when Iir_Kind_For_Generate_Statement => -            return "for generate statement"; -         when Iir_Kind_If_Generate_Statement -           | Iir_Kind_If_Generate_Else_Clause => -            return "if generate statement"; -         when Iir_Kind_Case_Generate_Statement => -            return "case generate statement"; -         when Iir_Kind_Generate_Statement_Body => -            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_Psl_Endpoint_Declaration => -            return Disp_Identifier (Node, "PSL endpoint 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_Subtype_Attribute => -            return "'subtype attribute"; -         when Iir_Kind_Element_Attribute => -            return "'element 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_Simple_Signal_Assignment => -            return Disp_Label -              (Node, "concurrent simple signal assignment"); -         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_Simple_Signal_Assignment_Statement => -            return Disp_Label (Node, "signal assignment statement"); -         when Iir_Kind_Conditional_Signal_Assignment_Statement => -            return Disp_Label -              (Node, "conditional signal assignment statement"); -         when Iir_Kind_Selected_Waveform_Assignment_Statement => -            return Disp_Label -              (Node, "selected waveform assignment statement"); -         when Iir_Kind_Variable_Assignment_Statement => -            return Disp_Label (Node, "variable assignment statement"); -         when Iir_Kind_Conditional_Variable_Assignment_Statement => -            return Disp_Label -              (Node, "conditional 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 Disp_Location (Node: Iir) return String is -   begin -      return Image (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)); -            if Decl = Null_Iir then -               Append (Res, "*unknown*"); -               return; -            end if; -         end if; -         Append (Res, Image (Get_Identifier (Decl))); -      end Append_Type; - +   function Make_Earg_Vhdl_Node (V : Iir) return Earg_Type is     begin -      case Get_Kind (Subprg) is -         when Iir_Kind_Enumeration_Literal => -            Append (Res, "enumeration literal "); -         when Iir_Kind_Function_Declaration -           | Iir_Kind_Interface_Function_Declaration => -            Append (Res, "function "); -         when Iir_Kind_Procedure_Declaration -           | Iir_Kind_Interface_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 -         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, Image (Id)); -               Append (Res, """"); -            when others => -               Append (Res, Image (Id)); -         end case; -      end; - -      Append (Res, " ["); - -      case Get_Kind (Subprg) is -         when Iir_Kinds_Subprogram_Declaration -           | Iir_Kinds_Interface_Subprogram_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_Function_Declaration -           | Iir_Kind_Interface_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; -            List : constant Iir_List := Get_Overload_List (A_Type); -            Nbr : constant Natural := Get_Nbr_Elements (List); -            Res : Unbounded_String; -            El : Iir; -            It : List_Iterator; -         begin -            if Nbr = 0 then -               return "unknown"; -            elsif Nbr = 1 then -               return Disp_Type_Name (Get_First_Element (List)); -            else -               Append (Res, "one of "); -               It := List_Iterate (List); -               for I in 0 .. Nbr - 1 loop -                  pragma Assert (Is_Valid (It)); -                  El := Get_Element (It); -                  Append (Res, Disp_Type_Name (El)); -                  if I < Nbr - 2 then -                     Append (Res, ", "); -                  elsif I = Nbr - 2 then -                     Append (Res, " or "); -                  end if; -                  Next (It); -               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 -     (Origin : Report_Origin; Caller : Iir; Callee : Iir; Loc : Iir) -   is -      L : Iir; -   begin -      if Loc = Null_Iir then -         L := Caller; -      else -         L := Loc; -      end if; -      Error_Msg_Relaxed -        (Origin, Warnid_Pure, -         "pure " & Disp_Node (Caller) & " cannot call (impure) " -         & Disp_Node (Callee), L); -      Error_Msg_Relaxed -        (Origin, Warnid_Pure, -         "(" & Disp_Node (Callee) & " is defined here)", Callee); -   end Error_Pure; +      return (Kind => Earg_Iir, Val_Iir => V); +   end Make_Earg_Vhdl_Node; -   procedure Error_Not_Match (Expr: Iir; A_Type: Iir) is +   function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) +                                 return Earg_Type is     begin -      if Get_Kind (A_Type) = Iir_Kind_Error then -         --  Cascade error message. -         return; -      end if; -      Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type " -                     & Disp_Node (A_Type), Expr); -   end Error_Not_Match; +      return (Kind => Earg_Token, Val_Tok => V); +   end Make_Earg_Vhdl_Token; -   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; diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads index 6825b1c0d..1abacca3a 100644 --- a/src/vhdl/errorout.ads +++ b/src/vhdl/errorout.ads @@ -24,8 +24,6 @@ package Errorout is     Compilation_Error: exception;     --  This kind can't be handled. -   procedure Error_Kind (Msg: String; An_Iir: in Iir); -   procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions);     procedure Error_Kind (Msg : String; N : PSL_Node);     pragma No_Return (Error_Kind); @@ -163,15 +161,12 @@ package Errorout is     --  %n: node name     --  %s: a string     --  TODO: %m: mode, %y: type of -   function "+" (V : Iir) return Earg_Type;     function "+" (V : Location_Type) return Earg_Type;     function "+" (V : Name_Id) return Earg_Type; -   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type;     function "+" (V : Character) return Earg_Type;     function "+" (V : String8_Len_Type) return Earg_Type;     --  Convert location. -   function "+" (L : Iir) return Location_Type;     function "+" (L : PSL_Node) return Location_Type;     --  Pass that detected the error. @@ -230,104 +225,8 @@ package Errorout is     --  Warn about an option.     procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String); -   -- Disp a message during semantic analysis. -   procedure Warning_Msg_Sem (Id : Msgid_Warnings; -                              Loc : Location_Type; -                              Msg: String; -                              Args : Earg_Arr := No_Eargs; -                              Cont : Boolean := False); -   procedure Warning_Msg_Sem (Id : Msgid_Warnings; -                              Loc : Location_Type; -                              Msg: String; -                              Arg1 : Earg_Type; -                              Cont : Boolean := False); - -   procedure Error_Msg_Sem (Loc: Location_Type; -                            Msg: String; -                            Args : Earg_Arr := No_Eargs; -                            Cont : Boolean := False); -   procedure Error_Msg_Sem -     (Loc: Location_Type; Msg: String; Arg1 : Earg_Type); -   procedure Error_Msg_Sem_1 (Msg: String; Loc : PSL_Node); - -   --  Like Error_Msg_Sem, but a warning if -frelaxed or --std=93c. -   procedure Error_Msg_Sem_Relaxed (Loc : Iir; -                                    Id : Msgid_Warnings; -                                    Msg : String; -                                    Args : Earg_Arr := No_Eargs); - -   -- Disp a message during elaboration (or configuration). -   procedure Error_Msg_Elab -     (Msg: String; Args : Earg_Arr := No_Eargs); -   procedure Error_Msg_Elab -     (Msg: String; Arg1 : Earg_Type); -   procedure Error_Msg_Elab -     (Loc: Iir; Msg: String; Args : Earg_Arr := No_Eargs); -   procedure Error_Msg_Elab -     (Loc: Iir; Msg: String; Arg1 : Earg_Type); - -   --  Like Error_Msg_Elab, but a warning if -frelaxed or --std=93c. -   procedure Error_Msg_Elab_Relaxed (Loc : Iir; -                                     Id : Msgid_Warnings; -                                     Msg : String; -                                     Args : Earg_Arr := No_Eargs); - -   --  Disp a warning durig elaboration (or configuration). -   procedure Warning_Msg_Elab (Id : Msgid_Warnings; -                               Loc : Iir; -                               Msg: String; -                               Arg1 : Earg_Type; -                               Cont : Boolean := False); -   procedure Warning_Msg_Elab (Id : Msgid_Warnings; -                               Loc : Iir; -                               Msg: String; -                               Args : Earg_Arr := No_Eargs; -                               Cont : Boolean := False); - -   -- Disp a bug message. -   procedure Error_Internal (Expr: Iir; Msg: String := ""); -   pragma No_Return (Error_Internal); - -   -- Disp a node. -   -- Used for output of message. -   function Disp_Node (Node: Iir) return String; - -   -- Disp a node location. -   -- Used for output of message. -   function Disp_Location (Node: Iir) return String; - -   --  Disp non-terminal name from KIND. -   function Disp_Name (Kind : Iir_Kind) return String; - -   --  SUBPRG must be a subprogram declaration or an enumeration literal -   --  declaration. -   --  Returns: -   --   "enumeration literal XX [ return TYPE ]" -   --   "function XXX [ TYPE1, TYPE2 return TYPE ]" -   --   "procedure XXX [ TYPE1, TYPE2 ]" -   --   "implicit function XXX [ TYPE1, TYPE2 return TYPE ]" -   --   "implicit procedure XXX [ TYPE1, TYPE2 ]" -   function Disp_Subprg (Subprg : Iir) return String; - -   --  Print element POS of discrete type DTYPE. -   function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String; - -   --  Disp the name of the type of NODE if known. -   --  Disp "unknown" if it is not known. -   --  Disp all possible types if it is an overload list. -   function Disp_Type_Of (Node : Iir) return String; - -   --  Disp an error message when a pure function CALLER calls impure CALLEE. -   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 EXPR. -   procedure Error_Not_Match (Expr: Iir; A_Type: Iir); - -   --  Disp interface mode MODE. -   function Get_Mode_Name (Mode : Iir_Mode) return String; - +   function Make_Earg_Vhdl_Node (V : Iir) return Earg_Type; +   function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) return Earg_Type;  private     type Earg_Kind is       (Earg_None, diff --git a/src/vhdl/psl-errors.ads b/src/vhdl/psl-errors.ads index c65443aee..4d33faa51 100644 --- a/src/vhdl/psl-errors.ads +++ b/src/vhdl/psl-errors.ads @@ -1,5 +1,6 @@  with Types; use Types;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Files_Map;  package PSL.Errors is @@ -10,5 +11,5 @@ package PSL.Errors is       Errorout.Error_Kind;     procedure Error_Msg_Sem (Msg: String; Loc: PSL_Node) -     renames Errorout.Error_Msg_Sem_1; +     renames Vhdl.Errors.Error_Msg_Sem_1;  end PSL.Errors; diff --git a/src/vhdl/simulate/simul-annotations.adb b/src/vhdl/simulate/simul-annotations.adb index 6fe7852f6..240464eed 100644 --- a/src/vhdl/simulate/simul-annotations.adb +++ b/src/vhdl/simulate/simul-annotations.adb @@ -19,7 +19,7 @@  with Tables;  with Ada.Text_IO;  with Vhdl.Std_Package; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Types; use Types; diff --git a/src/vhdl/simulate/simul-debugger.adb b/src/vhdl/simulate/simul-debugger.adb index a50542f38..d4bf1bce8 100644 --- a/src/vhdl/simulate/simul-debugger.adb +++ b/src/vhdl/simulate/simul-debugger.adb @@ -37,6 +37,7 @@ with Simul.Elaboration; use Simul.Elaboration;  with Simul.Execution; use Simul.Execution;  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Disp_Vhdl;  with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk;  with Areapools; use Areapools; diff --git a/src/vhdl/simulate/simul-elaboration-ams.adb b/src/vhdl/simulate/simul-elaboration-ams.adb index f5cf20110..7772c9cf9 100644 --- a/src/vhdl/simulate/simul-elaboration-ams.adb +++ b/src/vhdl/simulate/simul-elaboration-ams.adb @@ -16,7 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Simul.Execution;  package body Simul.Elaboration.AMS is diff --git a/src/vhdl/simulate/simul-elaboration.adb b/src/vhdl/simulate/simul-elaboration.adb index 0d006f3a5..996a36804 100644 --- a/src/vhdl/simulate/simul-elaboration.adb +++ b/src/vhdl/simulate/simul-elaboration.adb @@ -19,6 +19,7 @@  with Ada.Text_IO;  with Str_Table;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Evaluation;  with Simul.Execution; use Simul.Execution;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/vhdl/simulate/simul-execution.adb b/src/vhdl/simulate/simul-execution.adb index 19f9286b0..a9411d62f 100644 --- a/src/vhdl/simulate/simul-execution.adb +++ b/src/vhdl/simulate/simul-execution.adb @@ -21,7 +21,7 @@ with Ada.Text_IO; use Ada.Text_IO;  with System;  with Grt.Types; use Grt.Types;  with Flags; use Flags; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package;  with Vhdl.Evaluation;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/vhdl/simulate/simul-simulation-main.adb b/src/vhdl/simulate/simul-simulation-main.adb index ab9b083fc..8a91ed179 100644 --- a/src/vhdl/simulate/simul-simulation-main.adb +++ b/src/vhdl/simulate/simul-simulation-main.adb @@ -21,6 +21,7 @@ with Ada.Text_IO; use Ada.Text_IO;  with Types; use Types;  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with PSL.Nodes;  with PSL.NFAs;  with PSL.NFAs.Utils; diff --git a/src/vhdl/translate/ortho_front.adb b/src/vhdl/translate/ortho_front.adb index f29dfa76f..ea375b1d0 100644 --- a/src/vhdl/translate/ortho_front.adb +++ b/src/vhdl/translate/ortho_front.adb @@ -33,6 +33,7 @@ with Vhdl.Sem;  with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;  with Errorout; use Errorout;  with Errorout.Console; +with Vhdl.Errors; use Vhdl.Errors;  with GNAT.OS_Lib;  with Bug;  with Trans_Be; diff --git a/src/vhdl/translate/trans-chap1.adb b/src/vhdl/translate/trans-chap1.adb index 164f7df3b..585b81fde 100644 --- a/src/vhdl/translate/trans-chap1.adb +++ b/src/vhdl/translate/trans-chap1.adb @@ -15,7 +15,8 @@  --  along with GCC; see the file COPYING.  If not, write to the Free  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; + +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Translation; use Translation;  with Trans.Chap2; diff --git a/src/vhdl/translate/trans-chap12.adb b/src/vhdl/translate/trans-chap12.adb index 540f775d6..469de7cf6 100644 --- a/src/vhdl/translate/trans-chap12.adb +++ b/src/vhdl/translate/trans-chap12.adb @@ -18,6 +18,7 @@  with Vhdl.Configuration;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Vhdl.Utils; use Vhdl.Utils;  with Libraries; diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb index 439fc7035..e95afb5c4 100644 --- a/src/vhdl/translate/trans-chap14.adb +++ b/src/vhdl/translate/trans-chap14.adb @@ -18,7 +18,7 @@  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Std_Package; use Vhdl.Std_Package; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Trans_Decls; use Trans_Decls;  with Trans.Chap3; diff --git a/src/vhdl/translate/trans-chap2.adb b/src/vhdl/translate/trans-chap2.adb index 0546a5cb7..7d32e50f6 100644 --- a/src/vhdl/translate/trans-chap2.adb +++ b/src/vhdl/translate/trans-chap2.adb @@ -18,7 +18,7 @@  with Std_Names;  with Vhdl.Std_Package; use Vhdl.Std_Package; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Sem_Inst;  with Vhdl.Nodes_Meta;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index 9388c8fdc..971d52b31 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -17,7 +17,7 @@  --  02111-1307, USA.  with Name_Table; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Trans.Chap2; diff --git a/src/vhdl/translate/trans-chap4.adb b/src/vhdl/translate/trans-chap4.adb index 91861f0c6..419229e66 100644 --- a/src/vhdl/translate/trans-chap4.adb +++ b/src/vhdl/translate/trans-chap4.adb @@ -16,7 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Files_Map;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Std_Package; use Vhdl.Std_Package; diff --git a/src/vhdl/translate/trans-chap5.adb b/src/vhdl/translate/trans-chap5.adb index b9c8e42d3..2aa7cfdea 100644 --- a/src/vhdl/translate/trans-chap5.adb +++ b/src/vhdl/translate/trans-chap5.adb @@ -16,7 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Trans.Chap3;  with Trans.Chap4; diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index ffb0581a0..9d0da87c8 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -17,7 +17,7 @@  --  02111-1307, USA.  with Files_Map; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Trans.Chap3; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index 347281d3a..98cc8894e 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -23,6 +23,7 @@ with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Nodes_Utils; use Vhdl.Nodes_Utils;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Flags; use Flags;  with Vhdl.Canon;  with Vhdl.Evaluation; use Vhdl.Evaluation; diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index 34adc93c6..79b05a055 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -18,7 +18,7 @@  with Ada.Text_IO;  with Std_Names; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Nodes_Utils;  with Vhdl.Canon;  with Vhdl.Evaluation; use Vhdl.Evaluation; diff --git a/src/vhdl/translate/trans-chap9.adb b/src/vhdl/translate/trans-chap9.adb index f6f7cc465..0ff2d31d0 100644 --- a/src/vhdl/translate/trans-chap9.adb +++ b/src/vhdl/translate/trans-chap9.adb @@ -18,6 +18,7 @@  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Flags;  with Libraries; diff --git a/src/vhdl/translate/trans-foreach_non_composite.adb b/src/vhdl/translate/trans-foreach_non_composite.adb index 373246415..e34e09e4a 100644 --- a/src/vhdl/translate/trans-foreach_non_composite.adb +++ b/src/vhdl/translate/trans-foreach_non_composite.adb @@ -16,7 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Trans.Chap3;  with Trans.Chap6; diff --git a/src/vhdl/translate/trans-rtis.adb b/src/vhdl/translate/trans-rtis.adb index 49b5b30a2..759a066cb 100644 --- a/src/vhdl/translate/trans-rtis.adb +++ b/src/vhdl/translate/trans-rtis.adb @@ -18,7 +18,7 @@  with Name_Table;  with Files_Map; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Configuration;  with Libraries; diff --git a/src/vhdl/translate/trans_analyzes.adb b/src/vhdl/translate/trans_analyzes.adb index b3940e398..8362938d8 100644 --- a/src/vhdl/translate/trans_analyzes.adb +++ b/src/vhdl/translate/trans_analyzes.adb @@ -21,6 +21,7 @@ with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk;  with Vhdl.Disp_Vhdl;  with Ada.Text_IO;  with Errorout; +with Vhdl.Errors; use Vhdl.Errors;  package body Trans_Analyzes is     Driver_List : Iir_List; diff --git a/src/vhdl/translate/trans_be.adb b/src/vhdl/translate/trans_be.adb index af76725d1..de7078651 100644 --- a/src/vhdl/translate/trans_be.adb +++ b/src/vhdl/translate/trans_be.adb @@ -15,7 +15,8 @@  --  along with GCC; see the file COPYING.  If not, write to the Free  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA. -with Errorout; use Errorout; + +with Vhdl.Errors; use Vhdl.Errors;  with Ada.Text_IO;  with Vhdl.Back_End; diff --git a/src/vhdl/translate/translation.adb b/src/vhdl/translate/translation.adb index 3f2ce1a7f..de83ba132 100644 --- a/src/vhdl/translate/translation.adb +++ b/src/vhdl/translate/translation.adb @@ -21,6 +21,7 @@ with Ortho_Ident; use Ortho_Ident;  with Flags; use Flags;  with Types; use Types;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Name_Table; -- use Name_Table;  with Str_Table;  with Files_Map; diff --git a/src/vhdl/vhdl-canon.adb b/src/vhdl/vhdl-canon.adb index 181e55217..29b52c798 100644 --- a/src/vhdl/vhdl-canon.adb +++ b/src/vhdl/vhdl-canon.adb @@ -16,6 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA.  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Types; use Types;  with Flags; use Flags; diff --git a/src/vhdl/vhdl-configuration.adb b/src/vhdl/vhdl-configuration.adb index e23d8e9cf..95ed0eb4e 100644 --- a/src/vhdl/vhdl-configuration.adb +++ b/src/vhdl/vhdl-configuration.adb @@ -18,6 +18,7 @@  with Libraries;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package;  with Name_Table; use Name_Table;  with Flags; diff --git a/src/vhdl/vhdl-disp_vhdl.adb b/src/vhdl/vhdl-disp_vhdl.adb index b6904c07f..464e003f1 100644 --- a/src/vhdl/vhdl-disp_vhdl.adb +++ b/src/vhdl/vhdl-disp_vhdl.adb @@ -24,6 +24,7 @@ with GNAT.OS_Lib;  with Vhdl.Std_Package;  with Flags; use Flags;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Name_Table;  with Str_Table; diff --git a/src/vhdl/vhdl-errors.adb b/src/vhdl/vhdl-errors.adb new file mode 100644 index 000000000..18ed5d4f8 --- /dev/null +++ b/src/vhdl/vhdl-errors.adb @@ -0,0 +1,990 @@ +--  Error message handling for vhdl. +--  Copyright (C) 2002-2019 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 Flags; use Flags; +with Name_Table; +with Files_Map; +with Vhdl.Utils; use Vhdl.Utils; +with Ada.Strings.Unbounded; +with Std_Names; +with Logging; use Logging; + +package body Vhdl.Errors is +   procedure Error_Kind (Msg : String; An_Iir : Iir) is +   begin +      Log_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 +      Log_Line +        (Msg & ": cannot handle " & Iir_Predefined_Functions'Image (Def)); +      raise Internal_Error; +   end Error_Kind; + +   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; + +   function "+" (L : Iir) return Location_Type renames Get_Location_Safe; + +      procedure Warning_Msg_Sem (Id : Msgid_Warnings; +                              Loc : Location_Type; +                              Msg: String; +                              Args : Earg_Arr := No_Eargs; +                              Cont : Boolean := False) is +   begin +      if Flags.Flag_Only_Elab_Warnings then +         return; +      end if; +      Report_Msg (Id, Semantic, Loc, Msg, Args, Cont); +   end Warning_Msg_Sem; + +   procedure Warning_Msg_Sem (Id : Msgid_Warnings; +                              Loc : Location_Type; +                              Msg: String; +                              Arg1 : Earg_Type; +                              Cont : Boolean := False) is +   begin +      Warning_Msg_Sem (Id, Loc, Msg, Earg_Arr'(1 => Arg1), Cont); +   end Warning_Msg_Sem; + +   procedure Warning_Msg_Elab (Id : Msgid_Warnings; +                               Loc : Iir; +                               Msg: String; +                               Arg1 : Earg_Type; +                               Cont : Boolean := False) is +   begin +      Report_Msg (Id, Elaboration, +Loc, Msg, Earg_Arr'(1 => Arg1), Cont); +   end Warning_Msg_Elab; + +   procedure Warning_Msg_Elab (Id : Msgid_Warnings; +                               Loc : Iir; +                               Msg: String; +                               Args : Earg_Arr := No_Eargs; +                               Cont : Boolean := False) is +   begin +      Report_Msg (Id, Elaboration, +Loc, Msg, Args, Cont); +   end Warning_Msg_Elab; + +   -- 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 (Msgid_Error, Semantic, Get_Location_Safe (Loc), Msg); +   end Error_Msg_Sem; + +   procedure Error_Msg_Sem (Loc: Location_Type; +                            Msg: String; +                            Args : Earg_Arr := No_Eargs; +                            Cont : Boolean := False) is +   begin +      Report_Msg (Msgid_Error, Semantic, Loc, Msg, Args, Cont); +   end Error_Msg_Sem; + +   procedure Error_Msg_Sem +     (Loc: Location_Type; Msg: String; Arg1 : Earg_Type) is +   begin +      Report_Msg (Msgid_Error, Semantic, Loc, Msg, (1 => Arg1)); +   end Error_Msg_Sem; + +   procedure Error_Msg_Sem_1 (Msg: String; Loc : PSL_Node) is +   begin +      Error_Msg_Sem (+Loc, Msg); +   end Error_Msg_Sem_1; + +   procedure Error_Msg_Relaxed (Origin : Report_Origin; +                                Id : Msgid_Warnings; +                                Msg : String; +                                Loc : Iir; +                                Args : Earg_Arr := No_Eargs) +   is +      Level : Msgid_Type; +   begin +      if Flag_Relaxed_Rules or Vhdl_Std = Vhdl_93c then +         if not Is_Warning_Enabled (Id) then +            return; +         end if; +         Level := Id; +      else +         Level := Msgid_Error; +      end if; +      Report_Msg (Level, Origin, Get_Location_Safe (Loc), Msg, Args); +   end Error_Msg_Relaxed; + +   procedure Error_Msg_Sem_Relaxed (Loc : Iir; +                                    Id : Msgid_Warnings; +                                    Msg : String; +                                    Args : Earg_Arr := No_Eargs) is +   begin +      Error_Msg_Relaxed (Semantic, Id, Msg, Loc, Args); +   end Error_Msg_Sem_Relaxed; + +   -- Disp a message during elaboration. +   procedure Error_Msg_Elab +     (Msg: String; Args : Earg_Arr := No_Eargs) is +   begin +      Report_Msg (Msgid_Error, Elaboration, No_Location, Msg, Args); +   end Error_Msg_Elab; + +   procedure Error_Msg_Elab +     (Msg: String; Arg1 : Earg_Type) is +   begin +      Error_Msg_Elab (Msg, Earg_Arr'(1 => Arg1)); +   end Error_Msg_Elab; + +   procedure Error_Msg_Elab +     (Loc: Iir; Msg: String; Args : Earg_Arr := No_Eargs) is +   begin +      Report_Msg (Msgid_Error, Elaboration, +Loc, Msg, Args); +   end Error_Msg_Elab; + +   procedure Error_Msg_Elab +     (Loc: Iir; Msg: String; Arg1 : Earg_Type) is +   begin +      Error_Msg_Elab (Loc, Msg, Earg_Arr'(1 => Arg1)); +   end Error_Msg_Elab; + +   procedure Error_Msg_Elab_Relaxed (Loc : Iir; +                                     Id : Msgid_Warnings; +                                     Msg : String; +                                     Args : Earg_Arr := No_Eargs) is +   begin +      Error_Msg_Relaxed (Elaboration, Id, Msg, Loc, Args); +   end Error_Msg_Elab_Relaxed; + +   -- Disp a bug message. +   procedure Error_Internal (Expr: in Iir; Msg: String := "") +   is +      pragma Unreferenced (Expr); +   begin +      Log ("internal error: "); +      Log_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 "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_Literal8 => +            return "string literal"; +         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_Unaffected_Waveform => +            return "unaffected waveform"; +         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_Conditional_Expression => +            return "conditional expression"; +         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 +           | Iir_Kind_Association_Element_Type +            | Iir_Kind_Association_Element_Subprogram => +            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_Wildcard_Type_Definition => +            return "<any>"; +         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_Interface_Type_Definition => +            return Disp_Type (Node, "interface 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 => +            return ''' & Name_Table.Image (Get_Identifier (Node)) & '''; +         when Iir_Kind_Simple_Name => +            return ''' & Name_Table.Image (Get_Identifier (Node)) & '''; +         when Iir_Kind_Reference_Name => +            --  Shouldn't happen. +            return "name"; +         when Iir_Kind_External_Constant_Name => +            return "external constant name"; +         when Iir_Kind_External_Signal_Name => +            return "external signal name"; +         when Iir_Kind_External_Variable_Name => +            return "external variable name"; + +         when Iir_Kind_Package_Pathname => +            return "package pathname"; +         when Iir_Kind_Absolute_Pathname => +            return "absolute pathname"; +         when Iir_Kind_Relative_Pathname => +            return "relative pathname"; +         when Iir_Kind_Pathname_Element => +            return "pathname element"; + +         when Iir_Kind_Entity_Aspect_Entity => +            declare +               Arch : constant Iir := Get_Architecture (Node); +               Ent : constant Iir := Get_Entity (Node); +            begin +               if Arch = Null_Iir then +                  return "aspect " & Disp_Node (Ent); +               else +                  return "aspect " & Disp_Node (Ent) +                    & '(' & Image_Identifier (Arch) & ')'; +               end if; +            end; +         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_Interface_Type_Declaration => +            return Disp_Identifier (Node, "type 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_Signal_Attribute_Declaration => +            --  Should not appear. +            return "signal attribute"; +         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_Function_Declaration => +            return Disp_Identifier (Node, "function"); +         when Iir_Kind_Interface_Procedure_Declaration => +            return Disp_Identifier (Node, "interface procedure"); +         when Iir_Kind_Interface_Function_Declaration => +            return Disp_Identifier (Node, "interface function"); +         when Iir_Kind_Procedure_Body +           | Iir_Kind_Function_Body => +            return "subprogram body"; + +         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_Context_Declaration => +            return Disp_Identifier (Node, "context"); +         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_Context_Reference => +            return "context reference"; +         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_Concurrent_Procedure_Call_Statement => +            return "concurrent procedure call"; +         when Iir_Kind_For_Generate_Statement => +            return "for generate statement"; +         when Iir_Kind_If_Generate_Statement +           | Iir_Kind_If_Generate_Else_Clause => +            return "if generate statement"; +         when Iir_Kind_Case_Generate_Statement => +            return "case generate statement"; +         when Iir_Kind_Generate_Statement_Body => +            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_Psl_Endpoint_Declaration => +            return Disp_Identifier (Node, "PSL endpoint 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_Subtype_Attribute => +            return "'subtype attribute"; +         when Iir_Kind_Element_Attribute => +            return "'element 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_Simple_Signal_Assignment => +            return Disp_Label +              (Node, "concurrent simple signal assignment"); +         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_Simple_Signal_Assignment_Statement => +            return Disp_Label (Node, "signal assignment statement"); +         when Iir_Kind_Conditional_Signal_Assignment_Statement => +            return Disp_Label +              (Node, "conditional signal assignment statement"); +         when Iir_Kind_Selected_Waveform_Assignment_Statement => +            return Disp_Label +              (Node, "selected waveform assignment statement"); +         when Iir_Kind_Variable_Assignment_Statement => +            return Disp_Label (Node, "variable assignment statement"); +         when Iir_Kind_Conditional_Variable_Assignment_Statement => +            return Disp_Label +              (Node, "conditional 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 Disp_Location (Node: Iir) return String is +   begin +      return Files_Map.Image (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)); +            if Decl = Null_Iir then +               Append (Res, "*unknown*"); +               return; +            end if; +         end if; +         Append (Res, Image (Get_Identifier (Decl))); +      end Append_Type; + +   begin +      case Get_Kind (Subprg) is +         when Iir_Kind_Enumeration_Literal => +            Append (Res, "enumeration literal "); +         when Iir_Kind_Function_Declaration +           | Iir_Kind_Interface_Function_Declaration => +            Append (Res, "function "); +         when Iir_Kind_Procedure_Declaration +           | Iir_Kind_Interface_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 +         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, Image (Id)); +               Append (Res, """"); +            when others => +               Append (Res, Image (Id)); +         end case; +      end; + +      Append (Res, " ["); + +      case Get_Kind (Subprg) is +         when Iir_Kinds_Subprogram_Declaration +           | Iir_Kinds_Interface_Subprogram_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_Function_Declaration +           | Iir_Kind_Interface_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; +            List : constant Iir_List := Get_Overload_List (A_Type); +            Nbr : constant Natural := Get_Nbr_Elements (List); +            Res : Unbounded_String; +            El : Iir; +            It : List_Iterator; +         begin +            if Nbr = 0 then +               return "unknown"; +            elsif Nbr = 1 then +               return Disp_Type_Name (Get_First_Element (List)); +            else +               Append (Res, "one of "); +               It := List_Iterate (List); +               for I in 0 .. Nbr - 1 loop +                  pragma Assert (Is_Valid (It)); +                  El := Get_Element (It); +                  Append (Res, Disp_Type_Name (El)); +                  if I < Nbr - 2 then +                     Append (Res, ", "); +                  elsif I = Nbr - 2 then +                     Append (Res, " or "); +                  end if; +                  Next (It); +               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 +     (Origin : Report_Origin; Caller : Iir; Callee : Iir; Loc : Iir) +   is +      L : Iir; +   begin +      if Loc = Null_Iir then +         L := Caller; +      else +         L := Loc; +      end if; +      Error_Msg_Relaxed +        (Origin, Warnid_Pure, +         "pure " & Disp_Node (Caller) & " cannot call (impure) " +         & Disp_Node (Callee), L); +      Error_Msg_Relaxed +        (Origin, Warnid_Pure, +         "(" & Disp_Node (Callee) & " is defined here)", Callee); +   end Error_Pure; + +   procedure Error_Not_Match (Expr: Iir; A_Type: Iir) is +   begin +      if Get_Kind (A_Type) = Iir_Kind_Error then +         --  Cascade error message. +         return; +      end if; +      Error_Msg_Sem ("can't match " & Disp_Node (Expr) & " with type " +                     & Disp_Node (A_Type), Expr); +   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 Vhdl.Errors; diff --git a/src/vhdl/vhdl-errors.ads b/src/vhdl/vhdl-errors.ads new file mode 100644 index 000000000..0b44c2795 --- /dev/null +++ b/src/vhdl/vhdl-errors.ads @@ -0,0 +1,136 @@ +--  Error message handling for vhdl. +--  Copyright (C) 2002-2019 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 Types; use Types; +with Errorout; use Errorout; +with Vhdl.Nodes; use Vhdl.Nodes; +with Vhdl.Tokens; + +package Vhdl.Errors is +   --  This kind can't be handled. +   procedure Error_Kind (Msg: String; An_Iir: in Iir); +   procedure Error_Kind (Msg: String; Def : Iir_Predefined_Functions); +   pragma No_Return (Error_Kind); + +   --  Conversions +   function "+" (V : Iir) return Earg_Type +     renames Errorout.Make_Earg_Vhdl_Node; +   function "+" (V : Vhdl.Tokens.Token_Type) return Earg_Type +     renames Errorout.Make_Earg_Vhdl_Token; + +   --  Convert location. +   function "+" (L : Iir) return Location_Type; + +      -- Disp a message during semantic analysis. +   procedure Warning_Msg_Sem (Id : Msgid_Warnings; +                              Loc : Location_Type; +                              Msg: String; +                              Args : Earg_Arr := No_Eargs; +                              Cont : Boolean := False); +   procedure Warning_Msg_Sem (Id : Msgid_Warnings; +                              Loc : Location_Type; +                              Msg: String; +                              Arg1 : Earg_Type; +                              Cont : Boolean := False); + +   procedure Error_Msg_Sem (Loc: Location_Type; +                            Msg: String; +                            Args : Earg_Arr := No_Eargs; +                            Cont : Boolean := False); +   procedure Error_Msg_Sem +     (Loc: Location_Type; Msg: String; Arg1 : Earg_Type); +   procedure Error_Msg_Sem_1 (Msg: String; Loc : PSL_Node); + +   --  Like Error_Msg_Sem, but a warning if -frelaxed or --std=93c. +   procedure Error_Msg_Sem_Relaxed (Loc : Iir; +                                    Id : Msgid_Warnings; +                                    Msg : String; +                                    Args : Earg_Arr := No_Eargs); + +   -- Disp a message during elaboration (or configuration). +   procedure Error_Msg_Elab +     (Msg: String; Args : Earg_Arr := No_Eargs); +   procedure Error_Msg_Elab +     (Msg: String; Arg1 : Earg_Type); +   procedure Error_Msg_Elab +     (Loc: Iir; Msg: String; Args : Earg_Arr := No_Eargs); +   procedure Error_Msg_Elab +     (Loc: Iir; Msg: String; Arg1 : Earg_Type); + +   --  Like Error_Msg_Elab, but a warning if -frelaxed or --std=93c. +   procedure Error_Msg_Elab_Relaxed (Loc : Iir; +                                     Id : Msgid_Warnings; +                                     Msg : String; +                                     Args : Earg_Arr := No_Eargs); + +   --  Disp a warning durig elaboration (or configuration). +   procedure Warning_Msg_Elab (Id : Msgid_Warnings; +                               Loc : Iir; +                               Msg: String; +                               Arg1 : Earg_Type; +                               Cont : Boolean := False); +   procedure Warning_Msg_Elab (Id : Msgid_Warnings; +                               Loc : Iir; +                               Msg: String; +                               Args : Earg_Arr := No_Eargs; +                               Cont : Boolean := False); + +   -- Disp a bug message. +   procedure Error_Internal (Expr: Iir; Msg: String := ""); +   pragma No_Return (Error_Internal); + +   -- Disp a node. +   -- Used for output of message. +   function Disp_Node (Node: Iir) return String; + +   -- Disp a node location. +   -- Used for output of message. +   function Disp_Location (Node: Iir) return String; + +   --  Disp non-terminal name from KIND. +   function Disp_Name (Kind : Iir_Kind) return String; + +   --  SUBPRG must be a subprogram declaration or an enumeration literal +   --  declaration. +   --  Returns: +   --   "enumeration literal XX [ return TYPE ]" +   --   "function XXX [ TYPE1, TYPE2 return TYPE ]" +   --   "procedure XXX [ TYPE1, TYPE2 ]" +   --   "implicit function XXX [ TYPE1, TYPE2 return TYPE ]" +   --   "implicit procedure XXX [ TYPE1, TYPE2 ]" +   function Disp_Subprg (Subprg : Iir) return String; + +   --  Print element POS of discrete type DTYPE. +   function Disp_Discrete (Dtype : Iir; Pos : Iir_Int64) return String; + +   --  Disp the name of the type of NODE if known. +   --  Disp "unknown" if it is not known. +   --  Disp all possible types if it is an overload list. +   function Disp_Type_Of (Node : Iir) return String; + +   --  Disp an error message when a pure function CALLER calls impure CALLEE. +   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 EXPR. +   procedure Error_Not_Match (Expr: Iir; A_Type: Iir); + +   --  Disp interface mode MODE. +   function Get_Mode_Name (Mode : Iir_Mode) return String; + +end Vhdl.Errors; diff --git a/src/vhdl/vhdl-evaluation.adb b/src/vhdl/vhdl-evaluation.adb index 6363411aa..ae2a38bc4 100644 --- a/src/vhdl/vhdl-evaluation.adb +++ b/src/vhdl/vhdl-evaluation.adb @@ -21,6 +21,7 @@ with Vhdl.Scanner;  with Errorout; use Errorout;  with Name_Table; use Name_Table;  with Str_Table; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Flags; use Flags; diff --git a/src/vhdl/vhdl-ieee-numeric.adb b/src/vhdl/vhdl-ieee-numeric.adb index 49f1ee4fb..c42fb59b4 100644 --- a/src/vhdl/vhdl-ieee-numeric.adb +++ b/src/vhdl/vhdl-ieee-numeric.adb @@ -19,7 +19,7 @@  with Types; use Types;  with Vhdl.Std_Package;  with Std_Names; use Std_Names; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Ieee.Std_Logic_1164;  package body Vhdl.Ieee.Numeric is diff --git a/src/vhdl/vhdl-ieee-std_logic_1164.adb b/src/vhdl/vhdl-ieee-std_logic_1164.adb index 6932dc9ef..58ce60769 100644 --- a/src/vhdl/vhdl-ieee-std_logic_1164.adb +++ b/src/vhdl/vhdl-ieee-std_logic_1164.adb @@ -18,7 +18,7 @@  with Types; use Types;  with Name_Table;  with Std_Names; use Std_Names; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  package body Vhdl.Ieee.Std_Logic_1164 is     function Is_Scalar_Parameter (Inter : Iir) return Boolean is diff --git a/src/vhdl/vhdl-ieee-vital_timing.adb b/src/vhdl/vhdl-ieee-vital_timing.adb index c4263672a..af68caabc 100644 --- a/src/vhdl/vhdl-ieee-vital_timing.adb +++ b/src/vhdl/vhdl-ieee-vital_timing.adb @@ -18,6 +18,7 @@  with Types; use Types;  with Std_Names;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Vhdl.Tokens; use Vhdl.Tokens;  with Name_Table; diff --git a/src/vhdl/vhdl-nodes_gc.adb b/src/vhdl/vhdl-nodes_gc.adb index 49fc0336a..7900355ec 100644 --- a/src/vhdl/vhdl-nodes_gc.adb +++ b/src/vhdl/vhdl-nodes_gc.adb @@ -20,7 +20,7 @@ with Ada.Unchecked_Deallocation;  with Types; use Types;  with Logging; use Logging;  with Vhdl.Nodes_Meta; use Vhdl.Nodes_Meta; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Libraries;  with Vhdl.Disp_Tree;  with Vhdl.Std_Package; diff --git a/src/vhdl/vhdl-nodes_walk.adb b/src/vhdl/vhdl-nodes_walk.adb index 2ada0a225..1f33ee23f 100644 --- a/src/vhdl/vhdl-nodes_walk.adb +++ b/src/vhdl/vhdl-nodes_walk.adb @@ -17,7 +17,7 @@  --  02111-1307, USA.  with Vhdl.Utils; use Vhdl.Utils; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  package body Vhdl.Nodes_Walk is     function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status diff --git a/src/vhdl/vhdl-parse.adb b/src/vhdl/vhdl-parse.adb index a3ef79e76..63c67ec29 100644 --- a/src/vhdl/vhdl-parse.adb +++ b/src/vhdl/vhdl-parse.adb @@ -20,6 +20,7 @@ with Vhdl.Tokens; use Vhdl.Tokens;  with Vhdl.Scanner; use Vhdl.Scanner;  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Std_Names; use Std_Names;  with Flags; use Flags;  with Vhdl.Parse_Psl; diff --git a/src/vhdl/vhdl-sem.adb b/src/vhdl/vhdl-sem.adb index 62ab6b653..dd353134e 100644 --- a/src/vhdl/vhdl-sem.adb +++ b/src/vhdl/vhdl-sem.adb @@ -16,6 +16,7 @@  --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA  --  02111-1307, USA.  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Vhdl.Ieee.Std_Logic_1164;  with Libraries; diff --git a/src/vhdl/vhdl-sem_assocs.adb b/src/vhdl/vhdl-sem_assocs.adb index 41b97953e..6c92566c6 100644 --- a/src/vhdl/vhdl-sem_assocs.adb +++ b/src/vhdl/vhdl-sem_assocs.adb @@ -17,6 +17,7 @@  --  02111-1307, USA.  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Flags; use Flags;  with Types; use Types;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/vhdl/vhdl-sem_decls.adb b/src/vhdl/vhdl-sem_decls.adb index 507ed1a3f..a45d37ecf 100644 --- a/src/vhdl/vhdl-sem_decls.adb +++ b/src/vhdl/vhdl-sem_decls.adb @@ -20,6 +20,7 @@ with Types; use Types;  with Std_Names;  with Vhdl.Tokens;  with Flags; use Flags; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Utils; use Vhdl.Utils; diff --git a/src/vhdl/vhdl-sem_expr.adb b/src/vhdl/vhdl-sem_expr.adb index 151d2d54c..988ee5df4 100644 --- a/src/vhdl/vhdl-sem_expr.adb +++ b/src/vhdl/vhdl-sem_expr.adb @@ -19,6 +19,7 @@  with Grt.Algos;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Flags; use Flags;  with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes;  with Vhdl.Sem_Names; use Vhdl.Sem_Names; diff --git a/src/vhdl/vhdl-sem_inst.adb b/src/vhdl/vhdl-sem_inst.adb index 7a8c6e36f..2fa563987 100644 --- a/src/vhdl/vhdl-sem_inst.adb +++ b/src/vhdl/vhdl-sem_inst.adb @@ -20,7 +20,7 @@ with Vhdl.Nodes_Meta;  with Types; use Types;  with Files_Map;  with Vhdl.Utils; use Vhdl.Utils; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Sem_Utils;  package body Vhdl.Sem_Inst is diff --git a/src/vhdl/vhdl-sem_lib.adb b/src/vhdl/vhdl-sem_lib.adb index 050beeee9..fcbb9bd1e 100644 --- a/src/vhdl/vhdl-sem_lib.adb +++ b/src/vhdl/vhdl-sem_lib.adb @@ -20,6 +20,7 @@ with Name_Table;  with Files_Map;  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Libraries; use Libraries;  with Vhdl.Scanner;  with Vhdl.Parse; diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb index 07773341b..1e104fbff 100644 --- a/src/vhdl/vhdl-sem_names.adb +++ b/src/vhdl/vhdl-sem_names.adb @@ -18,6 +18,7 @@  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Utils; use Vhdl.Utils;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Flags; use Flags;  with Name_Table;  with Vhdl.Std_Package; use Vhdl.Std_Package; diff --git a/src/vhdl/vhdl-sem_psl.adb b/src/vhdl/vhdl-sem_psl.adb index 994c1b833..4cf369d58 100644 --- a/src/vhdl/vhdl-sem_psl.adb +++ b/src/vhdl/vhdl-sem_psl.adb @@ -31,6 +31,7 @@ with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Std_Package;  with Vhdl.Ieee.Std_Logic_1164;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Xrefs; use Vhdl.Xrefs;  package body Vhdl.Sem_Psl is diff --git a/src/vhdl/vhdl-sem_scopes.adb b/src/vhdl/vhdl-sem_scopes.adb index c1f3fe8fd..0388faeb2 100644 --- a/src/vhdl/vhdl-sem_scopes.adb +++ b/src/vhdl/vhdl-sem_scopes.adb @@ -21,6 +21,7 @@ with Flags; use Flags;  with Name_Table; -- use Name_Table;  with Files_Map; use Files_Map;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Utils; use Vhdl.Utils;  package body Vhdl.Sem_Scopes is diff --git a/src/vhdl/vhdl-sem_specs.adb b/src/vhdl/vhdl-sem_specs.adb index 9329fff14..033c8afbb 100644 --- a/src/vhdl/vhdl-sem_specs.adb +++ b/src/vhdl/vhdl-sem_specs.adb @@ -21,6 +21,7 @@ with Vhdl.Sem_Names; use Vhdl.Sem_Names;  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Sem; use Vhdl.Sem;  with Vhdl.Sem_Lib; use Vhdl.Sem_Lib;  with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; diff --git a/src/vhdl/vhdl-sem_stmts.adb b/src/vhdl/vhdl-sem_stmts.adb index 18c38f67d..8248aee36 100644 --- a/src/vhdl/vhdl-sem_stmts.adb +++ b/src/vhdl/vhdl-sem_stmts.adb @@ -18,6 +18,7 @@  with Errorout; use Errorout;  with Types; use Types;  with Flags; use Flags; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Sem_Specs; use Vhdl.Sem_Specs;  with Vhdl.Std_Package; use Vhdl.Std_Package;  with Vhdl.Sem; use Vhdl.Sem; diff --git a/src/vhdl/vhdl-sem_types.adb b/src/vhdl/vhdl-sem_types.adb index 0cc7bf314..1ecf718f7 100644 --- a/src/vhdl/vhdl-sem_types.adb +++ b/src/vhdl/vhdl-sem_types.adb @@ -19,6 +19,7 @@ with Libraries;  with Flags; use Flags;  with Types; use Types;  with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Evaluation; use Vhdl.Evaluation;  with Vhdl.Sem_Utils;  with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; diff --git a/src/vhdl/vhdl-sem_utils.adb b/src/vhdl/vhdl-sem_utils.adb index 24a45a9a4..70573f6f1 100644 --- a/src/vhdl/vhdl-sem_utils.adb +++ b/src/vhdl/vhdl-sem_utils.adb @@ -18,7 +18,7 @@  with Ada.Unchecked_Conversion;  with Types; use Types;  with Flags; use Flags; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Nodes_Utils; use Vhdl.Nodes_Utils;  with Vhdl.Utils; use Vhdl.Utils;  with Vhdl.Ieee.Std_Logic_1164; diff --git a/src/vhdl/vhdl-utils.adb b/src/vhdl/vhdl-utils.adb index e93becc60..4a82dc7f2 100644 --- a/src/vhdl/vhdl-utils.adb +++ b/src/vhdl/vhdl-utils.adb @@ -17,7 +17,7 @@  --  02111-1307, USA.  with Vhdl.Scanner; use Vhdl.Scanner;  with Vhdl.Tokens; use Vhdl.Tokens; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Name_Table;  with Str_Table;  with Std_Names; use Std_Names; diff --git a/src/vhdl/vhdl-xrefs.adb b/src/vhdl/vhdl-xrefs.adb index 021acd485..f03535fbe 100644 --- a/src/vhdl/vhdl-xrefs.adb +++ b/src/vhdl/vhdl-xrefs.adb @@ -19,7 +19,7 @@ with Tables;  with GNAT.Heap_Sort_A;  with Flags;  with Vhdl.Std_Package; -with Errorout; use Errorout; +with Vhdl.Errors; use Vhdl.Errors;  with Vhdl.Nodes_Priv;  package body Vhdl.Xrefs is | 
