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