From 987a94c378dfb969e8bb7f1b734f29a33e63212e Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Thu, 9 May 2019 18:24:08 +0200 Subject: Move errorout from vhdl/ to src/ --- src/errorout-console.adb | 261 +++++++++++++++++++++++++ src/errorout-console.ads | 31 +++ src/errorout-memory.adb | 103 ++++++++++ src/errorout-memory.ads | 38 ++++ src/errorout.adb | 437 ++++++++++++++++++++++++++++++++++++++++++ src/errorout.ads | 274 ++++++++++++++++++++++++++ src/vhdl/errorout-console.adb | 261 ------------------------- src/vhdl/errorout-console.ads | 31 --- src/vhdl/errorout-memory.adb | 103 ---------- src/vhdl/errorout-memory.ads | 38 ---- src/vhdl/errorout.adb | 437 ------------------------------------------ src/vhdl/errorout.ads | 274 -------------------------- 12 files changed, 1144 insertions(+), 1144 deletions(-) create mode 100644 src/errorout-console.adb create mode 100644 src/errorout-console.ads create mode 100644 src/errorout-memory.adb create mode 100644 src/errorout-memory.ads create mode 100644 src/errorout.adb create mode 100644 src/errorout.ads delete mode 100644 src/vhdl/errorout-console.adb delete mode 100644 src/vhdl/errorout-console.ads delete mode 100644 src/vhdl/errorout-memory.adb delete mode 100644 src/vhdl/errorout-memory.ads delete mode 100644 src/vhdl/errorout.adb delete mode 100644 src/vhdl/errorout.ads (limited to 'src') diff --git a/src/errorout-console.adb b/src/errorout-console.adb new file mode 100644 index 000000000..0e9694811 --- /dev/null +++ b/src/errorout-console.adb @@ -0,0 +1,261 @@ +-- Output errors on the console. +-- Copyright (C) 2018 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY +-- WARRANTY; without even the implied warranty of MERCHANTABILITY or +-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with Ada.Text_IO; +with GNAT.OS_Lib; +with Name_Table; +with Files_Map; use Files_Map; +with Flags; use Flags; + +package body Errorout.Console is + -- Name of the program, used to report error message. + Program_Name : String_Acc := null; + + -- Terminal. + + -- Set Flag_Color_Diagnostics to On or Off if is was Auto. + procedure Detect_Terminal + is + -- Import isatty. + function isatty (Fd : Integer) return Integer; + pragma Import (C, isatty); + + -- Awful way to detect if the host is Windows. Should be replaced by + -- a host-specific package. + Is_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; + begin + if Flag_Color_Diagnostics = Auto then + if Is_Windows then + -- Off by default on Windows, as the consoles may not support + -- ANSI control sequences. Should be replaced by calls to the + -- Win32 API. + Flag_Color_Diagnostics := Off; + else + -- On Linux/Unix/Mac OS X: use color only when the output is to a + -- tty. + if isatty (2) /= 0 then + Flag_Color_Diagnostics := On; + else + Flag_Color_Diagnostics := Off; + end if; + end if; + end if; + end Detect_Terminal; + + -- Color to be used for various part of messages. + type Color_Type is (Color_Locus, + Color_Note, Color_Warning, Color_Error, Color_Fatal, + Color_Message, + Color_None); + + -- Switch to COLOR. + procedure Set_Color (Color : Color_Type) + is + procedure Put (S : String) + is + use Ada.Text_IO; + begin + Put (Standard_Error, S); + end Put; + begin + if Flag_Color_Diagnostics = Off then + return; + end if; + + -- Use ANSI sequences. + -- They are also documented on msdn in 'Console Virtual Terminal + -- sequences'. + + Put (ASCII.ESC & '['); + case Color is + when Color_Locus => Put ("1"); -- Bold + when Color_Note => Put ("1;36"); -- Bold, cyan + when Color_Warning => Put ("1;35"); -- Bold, magenta + when Color_Error => Put ("1;31"); -- Bold, red + when Color_Fatal => Put ("1;33"); -- Bold, yellow + when Color_Message => Put ("0;1"); -- Normal, bold + when Color_None => Put ("0"); -- Normal + end case; + Put ("m"); + end Set_Color; + + Msg_Len : Natural; + Current_Error : Error_Record; + + procedure Put (Str : String) + is + use Ada.Text_IO; + begin + Msg_Len := Msg_Len + Str'Length; + Put (Standard_Error, Str); + end Put; + + procedure Put (C : Character) + is + use Ada.Text_IO; + begin + Msg_Len := Msg_Len + 1; + Put (Standard_Error, C); + end Put; + + procedure Put_Line (Str : String := "") + is + use Ada.Text_IO; + begin + Put_Line (Standard_Error, Str); + Msg_Len := 0; + end Put_Line; + + procedure Set_Program_Name (Name : String) is + begin + Program_Name := new String'(Name); + end Set_Program_Name; + + procedure Disp_Program_Name is + begin + if Program_Name /= null then + Put (Program_Name.all); + Put (':'); + end if; + end Disp_Program_Name; + + procedure Disp_Location (File: Name_Id; Line: Natural; Col: Natural) is + begin + if File = Null_Identifier then + Put ("??"); + else + Put (Name_Table.Image (File)); + end if; + Put (':'); + Put (Natural_Image (Line)); + Put (':'); + Put (Natural_Image (Col)); + Put (':'); + end Disp_Location; + + procedure Console_Error_Start (E : Error_Record) + is + --- Coord_To_Position (File, Line_Pos, Offset, Name, Col); + Progname : Boolean; + begin + Current_Error := E; + + Detect_Terminal; + + -- And no program name. + Progname := False; + + case E.Origin is + when Option + | Library => + pragma Assert (E.File = No_Source_File_Entry); + Progname := True; + when Elaboration => + if E.File = No_Source_File_Entry then + Progname := True; + end if; + when others => + pragma Assert (E.File /= No_Source_File_Entry); + null; + end case; + + Msg_Len := 0; + + if Flag_Color_Diagnostics = On then + Set_Color (Color_Locus); + end if; + + if Progname then + Disp_Program_Name; + elsif E.File /= No_Source_File_Entry then + Disp_Location (Get_File_Name (E.File), E.Line, Get_Error_Col (E)); + else + Disp_Location (Null_Identifier, 0, 0); + end if; + + -- Display level. + case E.Id is + when Msgid_Note => + if Flag_Color_Diagnostics = On then + Set_Color (Color_Note); + end if; + Put ("note:"); + when Msgid_Warning | Msgid_Warnings => + if Flag_Color_Diagnostics = On then + Set_Color (Color_Warning); + end if; + Put ("warning:"); + when Msgid_Error => + if Flag_Color_Diagnostics = On then + Set_Color (Color_Error); + end if; + if Msg_Len = 0 + or else Flag_Color_Diagnostics = On + then + -- 'error:' is displayed only if not location is present, or + -- if messages are colored. + Put ("error:"); + end if; + when Msgid_Fatal => + if Flag_Color_Diagnostics = On then + Set_Color (Color_Fatal); + end if; + Put ("fatal:"); + end case; + + if Flag_Color_Diagnostics = On then + Set_Color (Color_Message); + end if; + Put (' '); + end Console_Error_Start; + + procedure Console_Message (Str : String) renames Put; + + procedure Console_Message_End is + begin + if Flag_Diagnostics_Show_Option + and then Current_Error.Id in Msgid_Warnings + then + Put (" [-W"); + Put (Warning_Image (Current_Error.Id)); + Put ("]"); + end if; + + if Flag_Color_Diagnostics = On then + Set_Color (Color_None); + end if; + + Put_Line; + + if Flag_Caret_Diagnostics + and then (Current_Error.File /= No_Source_File_Entry + and Current_Error.Line /= 0) + then + Put_Line (Extract_Expanded_Line (Current_Error.File, + Current_Error.Line)); + Put_Line ((1 .. Get_Error_Col (Current_Error) - 1 => ' ') & '^'); + end if; + end Console_Message_End; + + procedure Install_Handler is + begin + Set_Report_Handler ((Console_Error_Start'Access, + Console_Message'Access, + Console_Message_End'Access)); + end Install_Handler; +end Errorout.Console; diff --git a/src/errorout-console.ads b/src/errorout-console.ads new file mode 100644 index 000000000..9ec2f6d80 --- /dev/null +++ b/src/errorout-console.ads @@ -0,0 +1,31 @@ +-- Output errors on the console. +-- Copyright (C) 2018 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. + +package Errorout.Console is + -- Set the program name, used in error messages for options. Not displayed + -- if not initialized. + procedure Set_Program_Name (Name : String); + + -- Report handle for the console. + procedure Console_Error_Start (E : Error_Record); + procedure Console_Message (Str : String); + procedure Console_Message_End; + + -- Install the handlers for reporting errors. + procedure Install_Handler; +end Errorout.Console; diff --git a/src/errorout-memory.adb b/src/errorout-memory.adb new file mode 100644 index 000000000..83b694b74 --- /dev/null +++ b/src/errorout-memory.adb @@ -0,0 +1,103 @@ +-- Store error messages +-- Copyright (C) 2018 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 Tables; + +package body Errorout.Memory is + + type Char_Index is new Uns32; + + package Messages is new Tables + (Table_Component_Type => Character, + Table_Index_Type => Char_Index, + Table_Low_Bound => 1, + Table_Initial => 128); + + type Error_Element is record + Header : Error_Record; + Str : Char_Index; + end record; + + package Errors is new Tables + (Table_Component_Type => Error_Element, + Table_Index_Type => Error_Index, + Table_Low_Bound => 1, + Table_Initial => 32); + + function Get_Nbr_Messages return Error_Index is + begin + return Errors.Last; + end Get_Nbr_Messages; + + function Get_Error_Record (Idx : Error_Index) return Error_Record is + begin + return Errors.Table (Idx).Header; + end Get_Error_Record; + + function Get_Error_Message (Idx : Error_Index) return String + is + First : constant Char_Index := Errors.Table (Idx).Str; + Last : Char_Index; + begin + if Idx = Errors.Last then + Last := Messages.Last; + else + Last := Errors.Table (Idx + 1).Str - 1; + end if; + return String (Messages.Table (First .. Last - 1)); + end Get_Error_Message; + + function Get_Error_Message_Addr (Idx : Error_Index) return System.Address + is + First : constant Char_Index := Errors.Table (Idx).Str; + begin + return Messages.Table (First)'Address; + end Get_Error_Message_Addr; + + procedure Clear_Errors is + begin + Errors.Init; + Messages.Init; + Nbr_Errors := 0; + end Clear_Errors; + + procedure Memory_Error_Start (E : Error_Record) is + begin + Errors.Append ((E, Messages.Last + 1)); + end Memory_Error_Start; + + procedure Memory_Message (Str : String) is + begin + for I in Str'Range loop + Messages.Append (Str (I)); + end loop; + end Memory_Message; + + procedure Memory_Message_End is + begin + Messages.Append (ASCII.NUL); + end Memory_Message_End; + + procedure Install_Handler is + begin + Set_Report_Handler ((Memory_Error_Start'Access, + Memory_Message'Access, + Memory_Message_End'Access)); + end Install_Handler; + +end Errorout.Memory; diff --git a/src/errorout-memory.ads b/src/errorout-memory.ads new file mode 100644 index 000000000..4c638671e --- /dev/null +++ b/src/errorout-memory.ads @@ -0,0 +1,38 @@ +-- Store error messages +-- Copyright (C) 2018 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 System; + +package Errorout.Memory is + type Error_Index is new Uns32; + + -- Get number of messages available. + function Get_Nbr_Messages return Error_Index; + + -- Get messages. + -- Idx is from 1 to Nbr_Messages. + function Get_Error_Record (Idx : Error_Index) return Error_Record; + function Get_Error_Message (Idx : Error_Index) return String; + function Get_Error_Message_Addr (Idx : Error_Index) return System.Address; + + -- Remove all error messages. + procedure Clear_Errors; + + -- Install the handlers for reporting errors. + procedure Install_Handler; +end Errorout.Memory; diff --git a/src/errorout.adb b/src/errorout.adb new file mode 100644 index 000000000..1b022391d --- /dev/null +++ b/src/errorout.adb @@ -0,0 +1,437 @@ +-- 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 Files_Map; use Files_Map; +with Flags; use Flags; +with PSL.Nodes; +with Str_Table; + +with Vhdl.Errors; use Vhdl.Errors; + +package body Errorout is + 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 : 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 : 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 "+" (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; + + function Make_Earg_Vhdl_Node (V : Iir) return Earg_Type is + begin + return (Kind => Earg_Iir, Val_Iir => V); + end Make_Earg_Vhdl_Node; + + function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) + return Earg_Type is + begin + return (Kind => Earg_Token, Val_Tok => V); + end Make_Earg_Vhdl_Token; + + +end Errorout; diff --git a/src/errorout.ads b/src/errorout.ads new file mode 100644 index 000000000..1abacca3a --- /dev/null +++ b/src/errorout.ads @@ -0,0 +1,274 @@ +-- 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 Types; use Types; +with Vhdl.Nodes; use Vhdl.Nodes; +with Vhdl.Tokens; + +package Errorout is + Option_Error: exception; + Compilation_Error: exception; + + -- This kind can't be handled. + procedure Error_Kind (Msg : String; N : PSL_Node); + pragma No_Return (Error_Kind); + + -- The number of errors (ie, number of calls to error_msg*). + Nbr_Errors : Natural := 0; + + -- Maximum number of errors, before silent them. + Max_Nbr_Errors : constant Natural := 100; + + type Msgid_Type is + ( + -- Any note + Msgid_Note, + + -- Specific warnings + + -- Design unit redefines another design unit. + Warnid_Library, + + -- Missing Xref in pretty print. + Warnid_Missing_Xref, + + -- No default binding for a component instantiation. + Warnid_Default_Binding, + + -- Unbound component. + Warnid_Binding, + + -- Unconnected IN port without defaults (in relaxed mode). + Warnid_Port, + + -- Vhdl93 reserved word is used as a vhdl87 identifier. + Warnid_Reserved_Word, + + -- Start of block comment ('/*') appears in a block comment. + Warnid_Nested_Comment, + + -- Use of a tool directive. + Warnid_Directive, + + -- Weird use of parenthesis. + Warnid_Parenthesis, + + -- Generic of a vital entity is not a vital name. + Warnid_Vital_Generic, + + -- Delayed checks (checks performed at elaboration time). + Warnid_Delayed_Checks, + + -- Package body is not required but is analyzed. + Warnid_Body, + + -- An all/others specification does not apply, because there is no such + -- named entities. + Warnid_Specs, + + -- Incorrect use of universal value. + Warnid_Universal, + + -- Mismatch of bounds between actual and formal in a scalar port + -- association + Warnid_Port_Bounds, + + -- Runtime error detected at analysis time. + Warnid_Runtime_Error, + + -- Signal assignment creates a delta cycle in a postponed process. + Warnid_Delta_Cycle, + + -- Declaration of a shared variable with a non-protected type. + Warnid_Shared, + + -- A declaration hides a previous one. + Warnid_Hide, + + -- Emit a warning when a declaration is never used. + -- FIXME: currently only subprograms are handled. + Warnid_Unused, + + -- Others choice is not needed, all values are already covered. + Warnid_Others, + + -- Violation of pure rules. + Warnid_Pure, + + -- Violation of staticness rules + Warnid_Static, + + -- Any warning + Msgid_Warning, + + -- Any error + Msgid_Error, + + -- Any fatal error + Msgid_Fatal + ); + + -- All specific warning messages. + subtype Msgid_Warnings is Msgid_Type + range Warnid_Library .. Warnid_Static; + + -- Get the image of a warning. This correspond the the identifier of ID, + -- in lower case, without the Msgid_Warn_ prefix and with '_' replaced + -- by '-'. + function Warning_Image (Id : Msgid_Warnings) return String; + + -- Enable or disable a warning. + procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean); + + -- Get enable status of a warning. + function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean; + + -- State of warnings. + type Warnings_Setting is private; + + -- Global control of warnings. + -- Used to disable warnings while a referenced unit is analyzed. + procedure Save_Warnings_Setting (Res : out Warnings_Setting); + procedure Disable_All_Warnings; + procedure Restore_Warnings_Setting (Res : Warnings_Setting); + + type Earg_Type is private; + type Earg_Arr is array (Natural range <>) of Earg_Type; + + -- An empty array (for no arguments). + No_Eargs : constant Earg_Arr; + + -- Report display: + -- %%: % + -- %i: identifier + -- %c: character + -- %t: token + -- %l: location + -- %n: node name + -- %s: a string + -- TODO: %m: mode, %y: type of + function "+" (V : Location_Type) return Earg_Type; + function "+" (V : Name_Id) return Earg_Type; + function "+" (V : Character) return Earg_Type; + function "+" (V : String8_Len_Type) return Earg_Type; + + -- Convert location. + function "+" (L : PSL_Node) return Location_Type; + + -- Pass that detected the error. + type Report_Origin is + (Option, Library, Scan, Parse, Semantic, Elaboration); + + type Error_Record is record + Origin : Report_Origin; + Id : Msgid_Type; + Cont : Boolean; + File : Source_File_Entry; + + -- The first line is line 1, 0 can be used when line number is not + -- relevant. + Line : Natural; + + -- Offset in the line. The first character is at offset 0. + Offset : Natural; + + -- Length of the location (for a range). It is assumed to be on the + -- same line; use 0 when unknown. + Length : Natural; + end record; + + type Error_Start_Handler is access procedure (Err : Error_Record); + type Message_Handler is access procedure (Str : String); + type Message_End_Handler is access procedure; + + type Report_Msg_Handler is record + Error_Start : Error_Start_Handler; + Message : Message_Handler; + Message_End : Message_End_Handler; + end record; + + procedure Set_Report_Handler (Handler : Report_Msg_Handler); + + -- Generic report message. LOC maybe No_Location. + -- If ORIGIN is Option or Library, LOC must be No_Location and the program + -- name is displayed. + procedure Report_Msg (Id : Msgid_Type; + Origin : Report_Origin; + Loc : Location_Type; + Msg : String; + Args : Earg_Arr := No_Eargs; + Cont : Boolean := False); + + -- Disp an error, prepended with program name, and raise option_error. + -- This is used for errors before initialisation, such as bad option or + -- bad filename. + procedure Error_Msg_Option (Msg: String); + pragma No_Return (Error_Msg_Option); + + -- Same as Error_Msg_Option but do not raise Option_Error. + procedure Error_Msg_Option_NR (Msg: String); + + -- Warn about an option. + procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: 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, + Earg_Iir, Earg_Location, Earg_Id, Earg_Char, Earg_Token, Earg_String8); + + type Earg_Type (Kind : Earg_Kind := Earg_None) is record + case Kind is + when Earg_None => + null; + when Earg_Iir => + Val_Iir : Iir; + when Earg_Location => + Val_Loc : Location_Type; + when Earg_Id => + Val_Id : Name_Id; + when Earg_Char => + Val_Char : Character; + when Earg_Token => + Val_Tok : Vhdl.Tokens.Token_Type; + when Earg_String8 => + Val_Str8 : String8_Len_Type; + end case; + end record; + + No_Eargs : constant Earg_Arr := (1 .. 0 => (Kind => Earg_None)); + + type Warning_Control_Type is record + Enabled : Boolean; + Error : Boolean; + end record; + + type Warnings_Setting is array (Msgid_Warnings) of Warning_Control_Type; + + Default_Warnings : constant Warnings_Setting := + (Warnid_Library | Warnid_Binding | Warnid_Port | Warnid_Shared + | Warnid_Runtime_Error | Warnid_Pure | Warnid_Specs + | Warnid_Hide => (Enabled => True, Error => False), + others => (Enabled => False, Error => False)); + + -- Compute the column from Error_Record E. + function Get_Error_Col (E : Error_Record) return Natural; + + -- Image of VAL, without the leading space. + function Natural_Image (Val: Natural) return String; +end Errorout; diff --git a/src/vhdl/errorout-console.adb b/src/vhdl/errorout-console.adb deleted file mode 100644 index 0e9694811..000000000 --- a/src/vhdl/errorout-console.adb +++ /dev/null @@ -1,261 +0,0 @@ --- Output errors on the console. --- Copyright (C) 2018 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY --- WARRANTY; without even the implied warranty of MERCHANTABILITY or --- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. - -with Ada.Text_IO; -with GNAT.OS_Lib; -with Name_Table; -with Files_Map; use Files_Map; -with Flags; use Flags; - -package body Errorout.Console is - -- Name of the program, used to report error message. - Program_Name : String_Acc := null; - - -- Terminal. - - -- Set Flag_Color_Diagnostics to On or Off if is was Auto. - procedure Detect_Terminal - is - -- Import isatty. - function isatty (Fd : Integer) return Integer; - pragma Import (C, isatty); - - -- Awful way to detect if the host is Windows. Should be replaced by - -- a host-specific package. - Is_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; - begin - if Flag_Color_Diagnostics = Auto then - if Is_Windows then - -- Off by default on Windows, as the consoles may not support - -- ANSI control sequences. Should be replaced by calls to the - -- Win32 API. - Flag_Color_Diagnostics := Off; - else - -- On Linux/Unix/Mac OS X: use color only when the output is to a - -- tty. - if isatty (2) /= 0 then - Flag_Color_Diagnostics := On; - else - Flag_Color_Diagnostics := Off; - end if; - end if; - end if; - end Detect_Terminal; - - -- Color to be used for various part of messages. - type Color_Type is (Color_Locus, - Color_Note, Color_Warning, Color_Error, Color_Fatal, - Color_Message, - Color_None); - - -- Switch to COLOR. - procedure Set_Color (Color : Color_Type) - is - procedure Put (S : String) - is - use Ada.Text_IO; - begin - Put (Standard_Error, S); - end Put; - begin - if Flag_Color_Diagnostics = Off then - return; - end if; - - -- Use ANSI sequences. - -- They are also documented on msdn in 'Console Virtual Terminal - -- sequences'. - - Put (ASCII.ESC & '['); - case Color is - when Color_Locus => Put ("1"); -- Bold - when Color_Note => Put ("1;36"); -- Bold, cyan - when Color_Warning => Put ("1;35"); -- Bold, magenta - when Color_Error => Put ("1;31"); -- Bold, red - when Color_Fatal => Put ("1;33"); -- Bold, yellow - when Color_Message => Put ("0;1"); -- Normal, bold - when Color_None => Put ("0"); -- Normal - end case; - Put ("m"); - end Set_Color; - - Msg_Len : Natural; - Current_Error : Error_Record; - - procedure Put (Str : String) - is - use Ada.Text_IO; - begin - Msg_Len := Msg_Len + Str'Length; - Put (Standard_Error, Str); - end Put; - - procedure Put (C : Character) - is - use Ada.Text_IO; - begin - Msg_Len := Msg_Len + 1; - Put (Standard_Error, C); - end Put; - - procedure Put_Line (Str : String := "") - is - use Ada.Text_IO; - begin - Put_Line (Standard_Error, Str); - Msg_Len := 0; - end Put_Line; - - procedure Set_Program_Name (Name : String) is - begin - Program_Name := new String'(Name); - end Set_Program_Name; - - procedure Disp_Program_Name is - begin - if Program_Name /= null then - Put (Program_Name.all); - Put (':'); - end if; - end Disp_Program_Name; - - procedure Disp_Location (File: Name_Id; Line: Natural; Col: Natural) is - begin - if File = Null_Identifier then - Put ("??"); - else - Put (Name_Table.Image (File)); - end if; - Put (':'); - Put (Natural_Image (Line)); - Put (':'); - Put (Natural_Image (Col)); - Put (':'); - end Disp_Location; - - procedure Console_Error_Start (E : Error_Record) - is - --- Coord_To_Position (File, Line_Pos, Offset, Name, Col); - Progname : Boolean; - begin - Current_Error := E; - - Detect_Terminal; - - -- And no program name. - Progname := False; - - case E.Origin is - when Option - | Library => - pragma Assert (E.File = No_Source_File_Entry); - Progname := True; - when Elaboration => - if E.File = No_Source_File_Entry then - Progname := True; - end if; - when others => - pragma Assert (E.File /= No_Source_File_Entry); - null; - end case; - - Msg_Len := 0; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_Locus); - end if; - - if Progname then - Disp_Program_Name; - elsif E.File /= No_Source_File_Entry then - Disp_Location (Get_File_Name (E.File), E.Line, Get_Error_Col (E)); - else - Disp_Location (Null_Identifier, 0, 0); - end if; - - -- Display level. - case E.Id is - when Msgid_Note => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Note); - end if; - Put ("note:"); - when Msgid_Warning | Msgid_Warnings => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Warning); - end if; - Put ("warning:"); - when Msgid_Error => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Error); - end if; - if Msg_Len = 0 - or else Flag_Color_Diagnostics = On - then - -- 'error:' is displayed only if not location is present, or - -- if messages are colored. - Put ("error:"); - end if; - when Msgid_Fatal => - if Flag_Color_Diagnostics = On then - Set_Color (Color_Fatal); - end if; - Put ("fatal:"); - end case; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_Message); - end if; - Put (' '); - end Console_Error_Start; - - procedure Console_Message (Str : String) renames Put; - - procedure Console_Message_End is - begin - if Flag_Diagnostics_Show_Option - and then Current_Error.Id in Msgid_Warnings - then - Put (" [-W"); - Put (Warning_Image (Current_Error.Id)); - Put ("]"); - end if; - - if Flag_Color_Diagnostics = On then - Set_Color (Color_None); - end if; - - Put_Line; - - if Flag_Caret_Diagnostics - and then (Current_Error.File /= No_Source_File_Entry - and Current_Error.Line /= 0) - then - Put_Line (Extract_Expanded_Line (Current_Error.File, - Current_Error.Line)); - Put_Line ((1 .. Get_Error_Col (Current_Error) - 1 => ' ') & '^'); - end if; - end Console_Message_End; - - procedure Install_Handler is - begin - Set_Report_Handler ((Console_Error_Start'Access, - Console_Message'Access, - Console_Message_End'Access)); - end Install_Handler; -end Errorout.Console; diff --git a/src/vhdl/errorout-console.ads b/src/vhdl/errorout-console.ads deleted file mode 100644 index 9ec2f6d80..000000000 --- a/src/vhdl/errorout-console.ads +++ /dev/null @@ -1,31 +0,0 @@ --- Output errors on the console. --- Copyright (C) 2018 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. - -package Errorout.Console is - -- Set the program name, used in error messages for options. Not displayed - -- if not initialized. - procedure Set_Program_Name (Name : String); - - -- Report handle for the console. - procedure Console_Error_Start (E : Error_Record); - procedure Console_Message (Str : String); - procedure Console_Message_End; - - -- Install the handlers for reporting errors. - procedure Install_Handler; -end Errorout.Console; diff --git a/src/vhdl/errorout-memory.adb b/src/vhdl/errorout-memory.adb deleted file mode 100644 index 83b694b74..000000000 --- a/src/vhdl/errorout-memory.adb +++ /dev/null @@ -1,103 +0,0 @@ --- Store error messages --- Copyright (C) 2018 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 Tables; - -package body Errorout.Memory is - - type Char_Index is new Uns32; - - package Messages is new Tables - (Table_Component_Type => Character, - Table_Index_Type => Char_Index, - Table_Low_Bound => 1, - Table_Initial => 128); - - type Error_Element is record - Header : Error_Record; - Str : Char_Index; - end record; - - package Errors is new Tables - (Table_Component_Type => Error_Element, - Table_Index_Type => Error_Index, - Table_Low_Bound => 1, - Table_Initial => 32); - - function Get_Nbr_Messages return Error_Index is - begin - return Errors.Last; - end Get_Nbr_Messages; - - function Get_Error_Record (Idx : Error_Index) return Error_Record is - begin - return Errors.Table (Idx).Header; - end Get_Error_Record; - - function Get_Error_Message (Idx : Error_Index) return String - is - First : constant Char_Index := Errors.Table (Idx).Str; - Last : Char_Index; - begin - if Idx = Errors.Last then - Last := Messages.Last; - else - Last := Errors.Table (Idx + 1).Str - 1; - end if; - return String (Messages.Table (First .. Last - 1)); - end Get_Error_Message; - - function Get_Error_Message_Addr (Idx : Error_Index) return System.Address - is - First : constant Char_Index := Errors.Table (Idx).Str; - begin - return Messages.Table (First)'Address; - end Get_Error_Message_Addr; - - procedure Clear_Errors is - begin - Errors.Init; - Messages.Init; - Nbr_Errors := 0; - end Clear_Errors; - - procedure Memory_Error_Start (E : Error_Record) is - begin - Errors.Append ((E, Messages.Last + 1)); - end Memory_Error_Start; - - procedure Memory_Message (Str : String) is - begin - for I in Str'Range loop - Messages.Append (Str (I)); - end loop; - end Memory_Message; - - procedure Memory_Message_End is - begin - Messages.Append (ASCII.NUL); - end Memory_Message_End; - - procedure Install_Handler is - begin - Set_Report_Handler ((Memory_Error_Start'Access, - Memory_Message'Access, - Memory_Message_End'Access)); - end Install_Handler; - -end Errorout.Memory; diff --git a/src/vhdl/errorout-memory.ads b/src/vhdl/errorout-memory.ads deleted file mode 100644 index 4c638671e..000000000 --- a/src/vhdl/errorout-memory.ads +++ /dev/null @@ -1,38 +0,0 @@ --- Store error messages --- Copyright (C) 2018 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 System; - -package Errorout.Memory is - type Error_Index is new Uns32; - - -- Get number of messages available. - function Get_Nbr_Messages return Error_Index; - - -- Get messages. - -- Idx is from 1 to Nbr_Messages. - function Get_Error_Record (Idx : Error_Index) return Error_Record; - function Get_Error_Message (Idx : Error_Index) return String; - function Get_Error_Message_Addr (Idx : Error_Index) return System.Address; - - -- Remove all error messages. - procedure Clear_Errors; - - -- Install the handlers for reporting errors. - procedure Install_Handler; -end Errorout.Memory; diff --git a/src/vhdl/errorout.adb b/src/vhdl/errorout.adb deleted file mode 100644 index 1b022391d..000000000 --- a/src/vhdl/errorout.adb +++ /dev/null @@ -1,437 +0,0 @@ --- 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 Files_Map; use Files_Map; -with Flags; use Flags; -with PSL.Nodes; -with Str_Table; - -with Vhdl.Errors; use Vhdl.Errors; - -package body Errorout is - 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 : 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 : 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 "+" (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; - - function Make_Earg_Vhdl_Node (V : Iir) return Earg_Type is - begin - return (Kind => Earg_Iir, Val_Iir => V); - end Make_Earg_Vhdl_Node; - - function Make_Earg_Vhdl_Token (V : Vhdl.Tokens.Token_Type) - return Earg_Type is - begin - return (Kind => Earg_Token, Val_Tok => V); - end Make_Earg_Vhdl_Token; - - -end Errorout; diff --git a/src/vhdl/errorout.ads b/src/vhdl/errorout.ads deleted file mode 100644 index 1abacca3a..000000000 --- a/src/vhdl/errorout.ads +++ /dev/null @@ -1,274 +0,0 @@ --- 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 Types; use Types; -with Vhdl.Nodes; use Vhdl.Nodes; -with Vhdl.Tokens; - -package Errorout is - Option_Error: exception; - Compilation_Error: exception; - - -- This kind can't be handled. - procedure Error_Kind (Msg : String; N : PSL_Node); - pragma No_Return (Error_Kind); - - -- The number of errors (ie, number of calls to error_msg*). - Nbr_Errors : Natural := 0; - - -- Maximum number of errors, before silent them. - Max_Nbr_Errors : constant Natural := 100; - - type Msgid_Type is - ( - -- Any note - Msgid_Note, - - -- Specific warnings - - -- Design unit redefines another design unit. - Warnid_Library, - - -- Missing Xref in pretty print. - Warnid_Missing_Xref, - - -- No default binding for a component instantiation. - Warnid_Default_Binding, - - -- Unbound component. - Warnid_Binding, - - -- Unconnected IN port without defaults (in relaxed mode). - Warnid_Port, - - -- Vhdl93 reserved word is used as a vhdl87 identifier. - Warnid_Reserved_Word, - - -- Start of block comment ('/*') appears in a block comment. - Warnid_Nested_Comment, - - -- Use of a tool directive. - Warnid_Directive, - - -- Weird use of parenthesis. - Warnid_Parenthesis, - - -- Generic of a vital entity is not a vital name. - Warnid_Vital_Generic, - - -- Delayed checks (checks performed at elaboration time). - Warnid_Delayed_Checks, - - -- Package body is not required but is analyzed. - Warnid_Body, - - -- An all/others specification does not apply, because there is no such - -- named entities. - Warnid_Specs, - - -- Incorrect use of universal value. - Warnid_Universal, - - -- Mismatch of bounds between actual and formal in a scalar port - -- association - Warnid_Port_Bounds, - - -- Runtime error detected at analysis time. - Warnid_Runtime_Error, - - -- Signal assignment creates a delta cycle in a postponed process. - Warnid_Delta_Cycle, - - -- Declaration of a shared variable with a non-protected type. - Warnid_Shared, - - -- A declaration hides a previous one. - Warnid_Hide, - - -- Emit a warning when a declaration is never used. - -- FIXME: currently only subprograms are handled. - Warnid_Unused, - - -- Others choice is not needed, all values are already covered. - Warnid_Others, - - -- Violation of pure rules. - Warnid_Pure, - - -- Violation of staticness rules - Warnid_Static, - - -- Any warning - Msgid_Warning, - - -- Any error - Msgid_Error, - - -- Any fatal error - Msgid_Fatal - ); - - -- All specific warning messages. - subtype Msgid_Warnings is Msgid_Type - range Warnid_Library .. Warnid_Static; - - -- Get the image of a warning. This correspond the the identifier of ID, - -- in lower case, without the Msgid_Warn_ prefix and with '_' replaced - -- by '-'. - function Warning_Image (Id : Msgid_Warnings) return String; - - -- Enable or disable a warning. - procedure Enable_Warning (Id : Msgid_Warnings; Enable : Boolean); - - -- Get enable status of a warning. - function Is_Warning_Enabled (Id : Msgid_Warnings) return Boolean; - - -- State of warnings. - type Warnings_Setting is private; - - -- Global control of warnings. - -- Used to disable warnings while a referenced unit is analyzed. - procedure Save_Warnings_Setting (Res : out Warnings_Setting); - procedure Disable_All_Warnings; - procedure Restore_Warnings_Setting (Res : Warnings_Setting); - - type Earg_Type is private; - type Earg_Arr is array (Natural range <>) of Earg_Type; - - -- An empty array (for no arguments). - No_Eargs : constant Earg_Arr; - - -- Report display: - -- %%: % - -- %i: identifier - -- %c: character - -- %t: token - -- %l: location - -- %n: node name - -- %s: a string - -- TODO: %m: mode, %y: type of - function "+" (V : Location_Type) return Earg_Type; - function "+" (V : Name_Id) return Earg_Type; - function "+" (V : Character) return Earg_Type; - function "+" (V : String8_Len_Type) return Earg_Type; - - -- Convert location. - function "+" (L : PSL_Node) return Location_Type; - - -- Pass that detected the error. - type Report_Origin is - (Option, Library, Scan, Parse, Semantic, Elaboration); - - type Error_Record is record - Origin : Report_Origin; - Id : Msgid_Type; - Cont : Boolean; - File : Source_File_Entry; - - -- The first line is line 1, 0 can be used when line number is not - -- relevant. - Line : Natural; - - -- Offset in the line. The first character is at offset 0. - Offset : Natural; - - -- Length of the location (for a range). It is assumed to be on the - -- same line; use 0 when unknown. - Length : Natural; - end record; - - type Error_Start_Handler is access procedure (Err : Error_Record); - type Message_Handler is access procedure (Str : String); - type Message_End_Handler is access procedure; - - type Report_Msg_Handler is record - Error_Start : Error_Start_Handler; - Message : Message_Handler; - Message_End : Message_End_Handler; - end record; - - procedure Set_Report_Handler (Handler : Report_Msg_Handler); - - -- Generic report message. LOC maybe No_Location. - -- If ORIGIN is Option or Library, LOC must be No_Location and the program - -- name is displayed. - procedure Report_Msg (Id : Msgid_Type; - Origin : Report_Origin; - Loc : Location_Type; - Msg : String; - Args : Earg_Arr := No_Eargs; - Cont : Boolean := False); - - -- Disp an error, prepended with program name, and raise option_error. - -- This is used for errors before initialisation, such as bad option or - -- bad filename. - procedure Error_Msg_Option (Msg: String); - pragma No_Return (Error_Msg_Option); - - -- Same as Error_Msg_Option but do not raise Option_Error. - procedure Error_Msg_Option_NR (Msg: String); - - -- Warn about an option. - procedure Warning_Msg_Option (Id : Msgid_Warnings; Msg: 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, - Earg_Iir, Earg_Location, Earg_Id, Earg_Char, Earg_Token, Earg_String8); - - type Earg_Type (Kind : Earg_Kind := Earg_None) is record - case Kind is - when Earg_None => - null; - when Earg_Iir => - Val_Iir : Iir; - when Earg_Location => - Val_Loc : Location_Type; - when Earg_Id => - Val_Id : Name_Id; - when Earg_Char => - Val_Char : Character; - when Earg_Token => - Val_Tok : Vhdl.Tokens.Token_Type; - when Earg_String8 => - Val_Str8 : String8_Len_Type; - end case; - end record; - - No_Eargs : constant Earg_Arr := (1 .. 0 => (Kind => Earg_None)); - - type Warning_Control_Type is record - Enabled : Boolean; - Error : Boolean; - end record; - - type Warnings_Setting is array (Msgid_Warnings) of Warning_Control_Type; - - Default_Warnings : constant Warnings_Setting := - (Warnid_Library | Warnid_Binding | Warnid_Port | Warnid_Shared - | Warnid_Runtime_Error | Warnid_Pure | Warnid_Specs - | Warnid_Hide => (Enabled => True, Error => False), - others => (Enabled => False, Error => False)); - - -- Compute the column from Error_Record E. - function Get_Error_Col (E : Error_Record) return Natural; - - -- Image of VAL, without the leading space. - function Natural_Image (Val: Natural) return String; -end Errorout; -- cgit v1.2.3