diff options
Diffstat (limited to 'src/errorout-console.adb')
| -rw-r--r-- | src/errorout-console.adb | 261 |
1 files changed, 261 insertions, 0 deletions
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; |