path: root/src/vhdl/errorout.adb

--  Error message handling.
--  Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
--  GHDL is free software; you can redistribute it and/or modify it under
--  the terms of the GNU General Public License as published by the Free
--  Software Foundation; either version 2, or (at your option) any later
--  version.
--
--  GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
--  WARRANTY; without even the implied warranty of MERCHANTABILITY or
--  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
--  for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with GHDL; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.

with Logging; use Logging;
with Vhdl.Scanner;
with Name_Table;
with Iirs_Utils; use Iirs_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;

   procedure Error_Kind (Msg : String; N : PSL_Node) is
   begin
      Log (Msg);
      Log (": cannot handle ");
      Log_Line (PSL.Nodes.Nkind'Image (PSL.Nodes.Get_Kind (N)));
      raise Internal_Error;
   end Error_Kind;

   function Natural_Image (Val: Natural) return String
   is
      Str: constant String := Natural'Image (Val);
   begin
      return Str (Str'First + 1 .. Str'Last);
   end Natural_Image;

   function Get_Error_Col (E : Error_Record) return Natural
   is
      Line_Pos : Source_Ptr;
   begin
      Line_Pos := File_Line_To_Position (E.File, E.Line);
      return Coord_To_Col (E.File, Line_Pos, E.Offset);
   end Get_Error_Col;

   Report_Handler : Report_Msg_Handler;

   procedure Set_Report_Handler (Handler : Report_Msg_Handler) is
   begin
      Report_Handler := Handler;
   end Set_Report_Handler;

   --  Warnings.

   Warnings_Control : Warnings_Setting := Default_Warnings;

   procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean) is
   begin
      Warnings_Control (Id).Enabled := Enable;
   end Enable_Warning;

   function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean is
   begin
      return Warnings_Control (Id).Enabled;
   end Is_Warning_Enabled;

   function Warning_Image (Id : Msgid_Warnings) return String
   is
      Img : constant String := Msgid_Warnings'Image (Id);

      --  Prefix to strip.
      Prefix : constant String := "WARNID_";
      pragma Assert (Img'Length > Prefix'Length);
      pragma Assert (Img (1 .. Prefix'Length) = Prefix);
      Res : String (1 .. Img'Last - Prefix'Length);
      C : Character;
   begin
      --  Convert to lower cases, and '_' to '-'.
      for I in Res'Range loop
         C := Img (Prefix'Length + I);
         case C is
            when '_' =>
               C := '-';
            when 'A' .. 'Z' =>
               C := Character'Val (Character'Pos (C) + 32);
            when others =>
               raise Internal_Error;
         end case;
         Res (I) := C;
      end loop;

      return Res;
   end Warning_Image;

   procedure Save_Warnings_Setting (Res : out Warnings_Setting) is
   begin
      Res := Warnings_Control;
   end Save_Warnings_Setting;

   procedure Disable_All_Warnings is
   begin
      Warnings_Control := (others => (Enabled => False, Error => False));
   end Disable_All_Warnings;

   procedure Restore_Warnings_Setting (Res : Warnings_Setting) is
   begin
      Warnings_Control := Res;
   end Restore_Warnings_Setting;

   --  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);
   end "+";

   function "+" (V : Name_Id) return Earg_Type is
   begin
      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);
   end "+";

   function "+" (V : String8_Len_Type) return Earg_Type is
   begin
      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;
   begin
      if L = Null_Node then
         return No_Location;
      else
         return PSL.Nodes.Get_Location (L);
      end if;
   end "+";

   procedure Report_Msg (Id : Msgid_Type;
                         Origin : Report_Origin;
                         Loc : Location_Type;
                         Msg : String;
                         Args : Earg_Arr := No_Eargs;
                         Cont : Boolean := False)
   is
      procedure Location_To_Position (Location : Location_Type;
                                      File : out Source_File_Entry;
                                      Line : out Natural;
                                      Col : out Natural)
      is
         Name : Name_Id;
         Line_Pos : Source_Ptr;
         Offset : Natural;
      begin
         Location_To_Coord (Location, File, Line_Pos, Line, Offset);
         Coord_To_Position (File, Line_Pos, Offset, Name, Col);
      end Location_To_Position;

      File : Source_File_Entry;
      Line : Natural;
      New_Id : Msgid_Type;
      Offset : Natural;
      Loc_Length : Natural;
      Line_Pos : Source_Ptr;
      pragma Unreferenced (Line_Pos);
   begin
      --  Discard warnings that aren't enabled.
      if Id in Msgid_Warnings and then not Is_Warning_Enabled (Id) then
         return;
      end if;

      --  Reclassify warnings to errors if -Werror.
      if Flags.Warn_Error
        and then (Id = Msgid_Warning or Id in Msgid_Warnings)
      then
         New_Id := Msgid_Error;
      else
         New_Id := Id;
      end if;
      pragma Unreferenced (Id);

      --  Limit the number of errors.
      if not Cont and then New_Id = Msgid_Error then
         Nbr_Errors := Nbr_Errors + 1;
         if Nbr_Errors > Max_Nbr_Errors then
            return;
         end if;
      end if;

      --  Set error location.
      File := No_Source_File_Entry;
      Line := 0;
      Offset := 0;
      Loc_Length := 0;

      case Origin is
         when Option
           | Library =>
            pragma Assert (Loc = No_Location);
            null;
         when others =>
            if Loc /= No_Location then
               Location_To_Coord (Loc, File, Line_Pos, Line, Offset);
            else
               case Origin is
                  when Option
                    | Library =>
                     raise Program_Error;
                  when Elaboration =>
                     null;
                  when Scan =>
                     File := Vhdl.Scanner.Get_Current_Source_File;
                     Line := Vhdl.Scanner.Get_Current_Line;
                     Offset := Vhdl.Scanner.Get_Current_Offset;
                     Loc_Length := 1;
                  when Parse =>
                     File := Vhdl.Scanner.Get_Current_Source_File;
                     Line := Vhdl.Scanner.Get_Current_Line;
                     Offset := Vhdl.Scanner.Get_Token_Offset;
                     Loc_Length := Vhdl.Scanner.Get_Current_Offset - Offset;
                  when Semantic =>
                     null;
               end case;
            end if;
      end case;

      Report_Handler.Error_Start
        (Err => (Origin, New_Id, Cont, File, Line, Offset, Loc_Length));

      --  Display message.
      declare
         First, N : Positive;
         Argn : Integer;
      begin
         N := Msg'First;
         First := N;
         Argn := Args'First;
         while N <= Msg'Last loop
            if Msg (N) = '%' then
               Report_Handler.Message (Msg (First .. N - 1));
               First := N + 2;
               pragma Assert (N < Msg'Last);
               N := N + 1;
               case Msg (N) is
                  when '%' =>
                     Report_Handler.Message ("%");
                     Argn := Argn - 1;
                  when 'i' =>
                     --  Identifier.
                     declare
                        Arg : Earg_Type renames Args (Argn);
                        Id : Name_Id;
                     begin
                        Report_Handler.Message ("""");
                        case Arg.Kind is
                           when Earg_Iir =>
                              Id := Get_Identifier (Arg.Val_Iir);
                           when Earg_Id =>
                              Id := Arg.Val_Id;
                           when others =>
                              --  Invalid conversion to identifier.
                              raise Internal_Error;
                        end case;
                        Report_Handler.Message (Name_Table.Image (Id));
                        Report_Handler.Message ("""");
                     end;
                  when 'c' =>
                     --  Character
                     declare
                        Arg : Earg_Type renames Args (Argn);
                     begin
                        Report_Handler.Message ("'");
                        case Arg.Kind is
                           when Earg_Char =>
                              Report_Handler.Message ((1 => Arg.Val_Char));
                           when others =>
                              --  Invalid conversion to character.
                              raise Internal_Error;
                        end case;
                        Report_Handler.Message ("'");
                     end;
                  when 't' =>
                     --  A token
                     declare
                        use Vhdl.Tokens;
                        Arg : Earg_Type renames Args (Argn);
                        Tok : Token_Type;
                     begin
                        case Arg.Kind is
                           when Earg_Token =>
                              Tok := Arg.Val_Tok;
                           when others =>
                              --  Invalid conversion to character.
                              raise Internal_Error;
                        end case;
                        case Tok is
                           when Tok_Identifier =>
                              Report_Handler.Message ("an identifier");
                           when Tok_Eof =>
                              Report_Handler.Message ("end of file");
                           when others =>
                              Report_Handler.Message ("'");
                              Report_Handler.Message (Image (Tok));
                              Report_Handler.Message ("'");
                        end case;
                     end;
                  when 'l' =>
                     --  Location
                     declare
                        Arg : Earg_Type renames Args (Argn);
                        Arg_Loc : Location_Type;
                        Arg_File : Source_File_Entry;
                        Arg_Line : Natural;
                        Arg_Col : Natural;
                     begin
                        case Arg.Kind is
                           when Earg_Location =>
                              Arg_Loc := Arg.Val_Loc;
                           when Earg_Iir =>
                              Arg_Loc := Get_Location (Arg.Val_Iir);
                           when others =>
                              raise Internal_Error;
                        end case;
                        Location_To_Position
                          (Arg_Loc, Arg_File, Arg_Line, Arg_Col);

                        --  Do not print the filename if in the same file as
                        --  the error location.
                        if Arg_File = File then
                           Report_Handler.Message ("line ");
                        else
                           Report_Handler.Message
                             (Name_Table.Image (Get_File_Name (Arg_File)));
                           Report_Handler.Message (":");
                        end if;
                        Report_Handler.Message (Natural_Image (Arg_Line));
                        Report_Handler.Message (":");
                        Report_Handler.Message (Natural_Image (Arg_Col));
                     end;
                  when 'n' =>
                     --  Node
                     declare
                        Arg : Earg_Type renames Args (Argn);
                     begin
                        case Arg.Kind is
                           when Earg_Iir =>
                              Report_Handler.Message (Disp_Node (Arg.Val_Iir));
                           when others =>
                              --  Invalid conversion to node.
                              raise Internal_Error;
                        end case;
                     end;
                  when 's' =>
                     --  String
                     declare
                        Arg : Earg_Type renames Args (Argn);
                     begin
                        Report_Handler.Message ("""");
                        case Arg.Kind is
                           when Earg_String8 =>
                              Report_Handler.Message
                                (Str_Table.String_String8
                                   (Arg.Val_Str8.Str, Arg.Val_Str8.Len));
                           when others =>
                              --  Invalid conversion to character.
                              raise Internal_Error;
                        end case;
                        Report_Handler.Message ("""");
                     end;
                  when others =>
                     --  Unknown format.
                     raise Internal_Error;
               end case;
               Argn := Argn + 1;
            end if;
            N := N + 1;
         end loop;
         Report_Handler.Message (Msg (First .. N - 1));

         --  Are all arguments displayed ?
         pragma Assert (Argn > Args'Last);
      end;

      Report_Handler.Message_End.all;

      if not Cont
        and then New_Id = Msgid_Error
        and then Nbr_Errors = Max_Nbr_Errors
      then
         --  Limit reached.  Emit a message.
         Report_Handler.Error_Start (Err => (Option, Msgid_Error, False,
                                             No_Source_File_Entry, 0, 0, 0));
         Report_Handler.Message ("error limit reached");
         Report_Handler.Message_End.all;
      end if;
   end Report_Msg;

   procedure Error_Msg_Option_NR (Msg: String) is
   begin
      Report_Msg (Msgid_Error, Option, No_Location, Msg);
   end Error_Msg_Option_NR;

   procedure Error_Msg_Option (Msg: String) is
   begin
      Error_Msg_Option_NR (Msg);
      raise Option_Error;
   end Error_Msg_Option;

   procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: String) is
   begin
      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;

   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 Errorout;