1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- C O M P E R R -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by AdaCore. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- This package contains routines called when a fatal internal compiler error 27-- is detected. Calls to these routines cause termination of the current 28-- compilation with appropriate error output. 29 30with Atree; use Atree; 31with Debug; use Debug; 32with Errout; use Errout; 33with Gnatvsn; use Gnatvsn; 34with Lib; use Lib; 35with Namet; use Namet; 36with Opt; use Opt; 37with Osint; use Osint; 38with Output; use Output; 39with Sinfo; use Sinfo; 40with Sinput; use Sinput; 41with Sprint; use Sprint; 42with Sdefault; use Sdefault; 43with Treepr; use Treepr; 44with Types; use Types; 45 46with Ada.Exceptions; use Ada.Exceptions; 47 48with System.OS_Lib; use System.OS_Lib; 49with System.Soft_Links; use System.Soft_Links; 50 51package body Comperr is 52 53 ---------------- 54 -- Local Data -- 55 ---------------- 56 57 Abort_In_Progress : Boolean := False; 58 -- Used to prevent runaway recursion if something segfaults 59 -- while processing a previous abort. 60 61 ----------------------- 62 -- Local Subprograms -- 63 ----------------------- 64 65 procedure Repeat_Char (Char : Character; Col : Nat; After : Character); 66 -- Output Char until current column is at or past Col, and then output 67 -- the character given by After (if column is already past Col on entry, 68 -- then the effect is simply to output the After character). 69 70 -------------------- 71 -- Compiler_Abort -- 72 -------------------- 73 74 procedure Compiler_Abort 75 (X : String; 76 Fallback_Loc : String := ""; 77 From_GCC : Boolean := False) 78 is 79 -- The procedures below output a "bug box" with information about 80 -- the cause of the compiler abort and about the preferred method 81 -- of reporting bugs. The default is a bug box appropriate for 82 -- the FSF version of GNAT, but there are specializations for 83 -- the GNATPRO and Public releases by AdaCore. 84 85 XF : constant Positive := X'First; 86 -- Start index, usually 1, but we won't assume this 87 88 procedure End_Line; 89 -- Add blanks up to column 76, and then a final vertical bar 90 91 -------------- 92 -- End_Line -- 93 -------------- 94 95 procedure End_Line is 96 begin 97 Repeat_Char (' ', 76, '|'); 98 Write_Eol; 99 end End_Line; 100 101 Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL; 102 Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF; 103 104 -- Start of processing for Compiler_Abort 105 106 begin 107 Cancel_Special_Output; 108 109 -- Prevent recursion through Compiler_Abort, e.g. via SIGSEGV 110 111 if Abort_In_Progress then 112 Exit_Program (E_Abort); 113 end if; 114 115 Abort_In_Progress := True; 116 117 -- Generate a "standard" error message instead of a bug box in case 118 -- of CodePeer rather than generating a bug box, friendlier. 119 120 -- Note that the call to Error_Msg_N below sets Serious_Errors_Detected 121 -- to 1, so we use the regular mechanism below in order to display a 122 -- "compilation abandoned" message and exit, so we still know we have 123 -- this case (and -gnatdk can still be used to get the bug box). 124 125 if CodePeer_Mode 126 and then Serious_Errors_Detected = 0 127 and then not Debug_Flag_K 128 and then Sloc (Current_Error_Node) > No_Location 129 then 130 Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node); 131 end if; 132 133 -- If we are in CodePeer mode, we must also delete SCIL files 134 135 if CodePeer_Mode then 136 Delete_SCIL_Files; 137 end if; 138 139 -- If any errors have already occurred, then we guess that the abort 140 -- may well be caused by previous errors, and we don't make too much 141 -- fuss about it, since we want to let programmer fix the errors first. 142 143 -- Debug flag K disables this behavior (useful for debugging) 144 145 if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then 146 Errout.Finalize (Last_Call => True); 147 Errout.Output_Messages; 148 149 Set_Standard_Error; 150 Write_Str ("compilation abandoned due to previous error"); 151 Write_Eol; 152 153 Set_Standard_Output; 154 Source_Dump; 155 Tree_Dump; 156 Exit_Program (E_Errors); 157 158 -- Otherwise give message with details of the abort 159 160 else 161 Set_Standard_Error; 162 163 -- Generate header for bug box 164 165 Write_Char ('+'); 166 Repeat_Char ('=', 29, 'G'); 167 Write_Str ("NAT BUG DETECTED"); 168 Repeat_Char ('=', 76, '+'); 169 Write_Eol; 170 171 -- Output GNAT version identification 172 173 Write_Str ("| "); 174 Write_Str (Gnat_Version_String); 175 Write_Str (" ("); 176 177 -- Output target name, deleting junk final reverse slash 178 179 if Target_Name.all (Target_Name.all'Last) = '\' 180 or else Target_Name.all (Target_Name.all'Last) = '/' 181 then 182 Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1)); 183 else 184 Write_Str (Target_Name.all); 185 end if; 186 187 -- Output identification of error 188 189 Write_Str (") "); 190 191 if X'Length + Column > 76 then 192 if From_GCC then 193 Write_Str ("GCC error:"); 194 end if; 195 196 End_Line; 197 198 Write_Str ("| "); 199 end if; 200 201 if X'Length > 70 then 202 declare 203 Last_Blank : Integer := 70; 204 205 begin 206 for P in 39 .. 68 loop 207 if X (XF + P) = ' ' then 208 Last_Blank := P; 209 end if; 210 end loop; 211 212 Write_Str (X (XF .. XF - 1 + Last_Blank)); 213 End_Line; 214 Write_Str ("| "); 215 Write_Str (X (XF + Last_Blank .. X'Last)); 216 end; 217 else 218 Write_Str (X); 219 end if; 220 221 if not From_GCC then 222 223 -- For exception case, get exception message from the TSD. Note 224 -- that it would be neater and cleaner to pass the exception 225 -- message (obtained from Exception_Message) as a parameter to 226 -- Compiler_Abort, but we can't do this quite yet since it would 227 -- cause bootstrap path problems for 3.10 to 3.11. 228 229 Write_Char (' '); 230 Write_Str (Exception_Message (Get_Current_Excep.all.all)); 231 end if; 232 233 End_Line; 234 235 -- Output source location information 236 237 if Sloc (Current_Error_Node) <= No_Location then 238 if Fallback_Loc'Length > 0 then 239 Write_Str ("| Error detected around "); 240 Write_Str (Fallback_Loc); 241 else 242 Write_Str ("| No source file position information available"); 243 end if; 244 245 End_Line; 246 else 247 Write_Str ("| Error detected at "); 248 Write_Location (Sloc (Current_Error_Node)); 249 End_Line; 250 end if; 251 252 -- There are two cases now. If the file gnat_bug.box exists, 253 -- we use the contents of this file at this point. 254 255 declare 256 Lo : Source_Ptr; 257 Hi : Source_Ptr; 258 Src : Source_Buffer_Ptr; 259 260 begin 261 Namet.Unlock; 262 Name_Buffer (1 .. 12) := "gnat_bug.box"; 263 Name_Len := 12; 264 Read_Source_File (Name_Enter, 0, Hi, Src); 265 266 -- If we get a Src file, we use it 267 268 if Src /= null then 269 Lo := 0; 270 271 Outer : while Lo < Hi loop 272 Write_Str ("| "); 273 274 Inner : loop 275 exit Inner when Src (Lo) = ASCII.CR 276 or else Src (Lo) = ASCII.LF; 277 Write_Char (Src (Lo)); 278 Lo := Lo + 1; 279 end loop Inner; 280 281 End_Line; 282 283 while Lo <= Hi 284 and then (Src (Lo) = ASCII.CR 285 or else Src (Lo) = ASCII.LF) 286 loop 287 Lo := Lo + 1; 288 end loop; 289 end loop Outer; 290 291 -- Otherwise we use the standard fixed text 292 293 else 294 if Is_FSF_Version then 295 Write_Str 296 ("| Please submit a bug report; see" & 297 " http://gcc.gnu.org/bugs.html."); 298 End_Line; 299 300 elsif Is_GPL_Version then 301 302 Write_Str 303 ("| Please submit a bug report by email " & 304 "to report@adacore.com."); 305 End_Line; 306 307 Write_Str 308 ("| GAP members can alternatively use GNAT Tracker:"); 309 End_Line; 310 311 Write_Str 312 ("| http://www.adacore.com/ " & 313 "section 'send a report'."); 314 End_Line; 315 316 Write_Str 317 ("| See gnatinfo.txt for full info on procedure " & 318 "for submitting bugs."); 319 End_Line; 320 321 else 322 Write_Str 323 ("| Please submit a bug report using GNAT Tracker:"); 324 End_Line; 325 326 Write_Str 327 ("| http://www.adacore.com/gnattracker/ " & 328 "section 'send a report'."); 329 End_Line; 330 331 Write_Str 332 ("| alternatively submit a bug report by email " & 333 "to report@adacore.com,"); 334 End_Line; 335 336 Write_Str 337 ("| including your customer number #nnn " & 338 "in the subject line."); 339 End_Line; 340 end if; 341 342 Write_Str 343 ("| Use a subject line meaningful to you" & 344 " and us to track the bug."); 345 End_Line; 346 347 Write_Str 348 ("| Include the entire contents of this bug " & 349 "box in the report."); 350 End_Line; 351 352 Write_Str 353 ("| Include the exact command that you entered."); 354 End_Line; 355 356 Write_Str 357 ("| Also include sources listed below."); 358 End_Line; 359 360 if not Is_FSF_Version then 361 Write_Str 362 ("| Use plain ASCII or MIME attachment(s)."); 363 End_Line; 364 end if; 365 end if; 366 end; 367 368 -- Complete output of bug box 369 370 Write_Char ('+'); 371 Repeat_Char ('=', 76, '+'); 372 Write_Eol; 373 374 if Debug_Flag_3 then 375 Write_Eol; 376 Write_Eol; 377 Print_Tree_Node (Current_Error_Node); 378 Write_Eol; 379 end if; 380 381 Write_Eol; 382 383 Write_Line ("Please include these source files with error report"); 384 Write_Line ("Note that list may not be accurate in some cases, "); 385 Write_Line ("so please double check that the problem can still "); 386 Write_Line ("be reproduced with the set of files listed."); 387 Write_Line ("Consider also -gnatd.n switch (see debug.adb)."); 388 Write_Eol; 389 390 begin 391 Dump_Source_File_Names; 392 393 -- If we blow up trying to print the list of file names, just output 394 -- informative msg and continue. 395 396 exception 397 when others => 398 Write_Str ("list may be incomplete"); 399 end; 400 401 Write_Eol; 402 Set_Standard_Output; 403 404 Tree_Dump; 405 Source_Dump; 406 raise Unrecoverable_Error; 407 end if; 408 end Compiler_Abort; 409 410 ----------------------- 411 -- Delete_SCIL_Files -- 412 ----------------------- 413 414 procedure Delete_SCIL_Files is 415 Main : Node_Id; 416 Unit_Name : Node_Id; 417 418 Success : Boolean; 419 pragma Unreferenced (Success); 420 421 procedure Decode_Name_Buffer; 422 -- Replace "__" by "." in Name_Buffer, and adjust Name_Len accordingly 423 424 ------------------------ 425 -- Decode_Name_Buffer -- 426 ------------------------ 427 428 procedure Decode_Name_Buffer is 429 J : Natural; 430 K : Natural; 431 432 begin 433 J := 1; 434 K := 0; 435 while J <= Name_Len loop 436 K := K + 1; 437 438 if J < Name_Len 439 and then Name_Buffer (J) = '_' 440 and then Name_Buffer (J + 1) = '_' 441 then 442 Name_Buffer (K) := '.'; 443 J := J + 1; 444 else 445 Name_Buffer (K) := Name_Buffer (J); 446 end if; 447 448 J := J + 1; 449 end loop; 450 451 Name_Len := K; 452 end Decode_Name_Buffer; 453 454 -- Start of processing for Delete_SCIL_Files 455 456 begin 457 -- If parsing was not successful, no Main_Unit is available, so return 458 -- immediately. 459 460 if Main_Source_File = No_Source_File then 461 return; 462 end if; 463 464 -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and 465 -- SCIL/<unit>__body.scil, ditto for .scilx files. 466 467 Main := Unit (Cunit (Main_Unit)); 468 469 case Nkind (Main) is 470 when N_Subprogram_Body | N_Package_Declaration => 471 Unit_Name := Defining_Unit_Name (Specification (Main)); 472 473 when N_Package_Body => 474 Unit_Name := Corresponding_Spec (Main); 475 476 when N_Package_Renaming_Declaration => 477 Unit_Name := Defining_Unit_Name (Main); 478 479 -- No SCIL file generated for generic package declarations 480 481 when N_Generic_Package_Declaration => 482 return; 483 484 -- Should never happen, but can be ignored in production 485 486 when others => 487 pragma Assert (False); 488 return; 489 end case; 490 491 case Nkind (Unit_Name) is 492 when N_Defining_Identifier => 493 Get_Name_String (Chars (Unit_Name)); 494 495 when N_Defining_Program_Unit_Name => 496 Get_Name_String (Chars (Defining_Identifier (Unit_Name))); 497 Decode_Name_Buffer; 498 499 -- Should never happen, but can be ignored in production 500 501 when others => 502 pragma Assert (False); 503 return; 504 end case; 505 506 Delete_File 507 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success); 508 Delete_File 509 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success); 510 Delete_File 511 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success); 512 Delete_File 513 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success); 514 end Delete_SCIL_Files; 515 516 ----------------- 517 -- Repeat_Char -- 518 ----------------- 519 520 procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is 521 begin 522 while Column < Col loop 523 Write_Char (Char); 524 end loop; 525 526 Write_Char (After); 527 end Repeat_Char; 528 529end Comperr; 530