1-- Output errors on the console. 2-- Copyright (C) 2018 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with GNAT.OS_Lib; 18with Simple_IO; 19with Name_Table; 20with Files_Map; use Files_Map; 21with Flags; use Flags; 22 23package body Errorout.Console is 24 -- Name of the program, used to report error message. 25 Program_Name : String_Acc := null; 26 27 -- Terminal. 28 29 -- Set Flag_Color_Diagnostics to On or Off if is was Auto. 30 procedure Detect_Terminal 31 is 32 -- Import isatty. 33 function isatty (Fd : Integer) return Integer; 34 pragma Import (C, isatty); 35 36 -- Awful way to detect if the host is Windows. Should be replaced by 37 -- a host-specific package. 38 Is_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; 39 begin 40 if Flag_Color_Diagnostics = Auto then 41 if Is_Windows then 42 -- Off by default on Windows, as the consoles may not support 43 -- ANSI control sequences. Should be replaced by calls to the 44 -- Win32 API. 45 Flag_Color_Diagnostics := Off; 46 else 47 -- On Linux/Unix/Mac OS X: use color only when the output is to a 48 -- tty. 49 if isatty (2) /= 0 then 50 Flag_Color_Diagnostics := On; 51 else 52 Flag_Color_Diagnostics := Off; 53 end if; 54 end if; 55 end if; 56 end Detect_Terminal; 57 58 -- Color to be used for various part of messages. 59 type Color_Type is (Color_Locus, 60 Color_Note, Color_Warning, Color_Error, Color_Fatal, 61 Color_Message, 62 Color_None); 63 64 -- Switch to COLOR. 65 procedure Set_Color (Color : Color_Type) 66 is 67 use Simple_IO; 68 E : constant Character := ASCII.ESC; 69 begin 70 if Flag_Color_Diagnostics = Off then 71 return; 72 end if; 73 74 -- Use ANSI sequences. 75 -- They are also documented on msdn in 'Console Virtual Terminal 76 -- sequences'. 77 78 case Color is 79 when Color_Locus => Put_Err (E & "[1m"); -- Bold 80 when Color_Note => Put_Err (E & "[1;36m"); -- Bold, cyan 81 when Color_Warning => Put_Err (E & "[1;35m"); -- Bold, magenta 82 when Color_Error => Put_Err (E & "[1;31m"); -- Bold, red 83 when Color_Fatal => Put_Err (E & "[1;33m"); -- Bold, yellow 84 when Color_Message => Put_Err (E & "[0;1m"); -- Normal, bold 85 when Color_None => Put_Err (E & "[0m"); -- Normal 86 end case; 87 end Set_Color; 88 89 Msg_Len : Natural; 90 Current_Error : Error_Record; 91 Current_Line : Natural; 92 In_Group : Boolean := False; 93 94 procedure Put (Str : String) is 95 begin 96 Msg_Len := Msg_Len + Str'Length; 97 Simple_IO.Put_Err (Str); 98 end Put; 99 100 procedure Put (C : Character) is 101 begin 102 Msg_Len := Msg_Len + 1; 103 Simple_IO.Put_Err (C); 104 end Put; 105 106 procedure Put_Line (Str : String := "") is 107 begin 108 Simple_IO.Put_Line_Err (Str); 109 Msg_Len := 0; 110 end Put_Line; 111 112 procedure Set_Program_Name (Name : String) is 113 begin 114 Program_Name := new String'(Name); 115 end Set_Program_Name; 116 117 procedure Disp_Program_Name is 118 begin 119 if Program_Name /= null then 120 Put (Program_Name.all); 121 Put (':'); 122 end if; 123 end Disp_Program_Name; 124 125 procedure Disp_Location (File: Name_Id; Line: Natural; Col: Natural) is 126 begin 127 if File = Null_Identifier then 128 Put ("??"); 129 else 130 Put (Name_Table.Image (File)); 131 end if; 132 Put (':'); 133 Put (Natural_Image (Line)); 134 Put (':'); 135 Put (Natural_Image (Col)); 136 Put (':'); 137 end Disp_Location; 138 139 procedure Console_Error_Start (E : Error_Record) 140 is 141 --- Coord_To_Position (File, Line_Pos, Offset, Name, Col); 142 Progname : Boolean; 143 begin 144 Current_Error := E; 145 146 if In_Group then 147 Current_Line := Current_Line + 1; 148 else 149 pragma Assert (Current_Line <= 1); 150 Current_Line := 1; 151 end if; 152 153 -- And no program name. 154 Progname := False; 155 156 case E.Origin is 157 when Option 158 | Library => 159 pragma Assert (E.File = No_Source_File_Entry); 160 Progname := True; 161 when Elaboration => 162 if E.File = No_Source_File_Entry then 163 Progname := True; 164 end if; 165 when others => 166 pragma Assert (E.File /= No_Source_File_Entry); 167 null; 168 end case; 169 170 Msg_Len := 0; 171 172 if Flag_Color_Diagnostics = On then 173 Set_Color (Color_Locus); 174 end if; 175 176 if Progname then 177 Disp_Program_Name; 178 elsif E.File /= No_Source_File_Entry then 179 Disp_Location (Get_File_Name (E.File), E.Line, Get_Error_Col (E)); 180 else 181 Disp_Location (Null_Identifier, 0, 0); 182 end if; 183 184 -- Display level. 185 case E.Id is 186 when Msgid_Note => 187 if Flag_Color_Diagnostics = On then 188 Set_Color (Color_Note); 189 end if; 190 Put ("note:"); 191 when Msgid_Warning | Msgid_Warnings => 192 if Flag_Color_Diagnostics = On then 193 Set_Color (Color_Warning); 194 end if; 195 Put ("warning:"); 196 when Msgid_Error => 197 if Flag_Color_Diagnostics = On then 198 Set_Color (Color_Error); 199 end if; 200 if Msg_Len = 0 201 or else Flag_Color_Diagnostics = On 202 then 203 -- 'error:' is displayed only if not location is present, or 204 -- if messages are colored. 205 Put ("error:"); 206 end if; 207 when Msgid_Fatal => 208 if Flag_Color_Diagnostics = On then 209 Set_Color (Color_Fatal); 210 end if; 211 Put ("fatal:"); 212 end case; 213 214 if Flag_Color_Diagnostics = On then 215 Set_Color (Color_Message); 216 end if; 217 Put (' '); 218 end Console_Error_Start; 219 220 procedure Console_Message (Str : String) renames Put; 221 222 procedure Console_Message_End is 223 begin 224 if Current_Line = 1 225 and then Flag_Diagnostics_Show_Option 226 and then Current_Error.Id in Msgid_Warnings 227 then 228 Put (" [-W"); 229 Put (Warning_Image (Current_Error.Id)); 230 Put ("]"); 231 end if; 232 233 if Flag_Color_Diagnostics = On then 234 Set_Color (Color_None); 235 end if; 236 237 Put_Line; 238 239 if Current_Line = 1 240 and then Flag_Caret_Diagnostics 241 and then (Current_Error.File /= No_Source_File_Entry 242 and Current_Error.Line /= 0) 243 then 244 Put_Line (Extract_Expanded_Line (Current_Error.File, 245 Current_Error.Line)); 246 Put_Line ((1 .. Get_Error_Col (Current_Error) - 1 => ' ') & '^'); 247 end if; 248 end Console_Message_End; 249 250 procedure Console_Message_Group (Start : Boolean) is 251 begin 252 Current_Line := 0; 253 pragma Assert (In_Group /= Start); 254 In_Group := Start; 255 end Console_Message_Group; 256 257 procedure Install_Handler is 258 begin 259 Detect_Terminal; 260 261 Set_Report_Handler ((Console_Error_Start'Access, 262 Console_Message'Access, 263 Console_Message_End'Access, 264 Console_Message_Group'Access)); 265 end Install_Handler; 266end Errorout.Console; 267