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-2014, 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 Fallback_Loc : String := ""; 78 From_GCC : Boolean := False) 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 119 -- of .NET compiler, since we do not support all constructs of the 120 -- language. Of course ideally, we should detect this before bombing on 121 -- e.g. an assertion error, but in practice most of these bombs are due 122 -- to a legitimate case of a construct not being supported (in a sense 123 -- they all are, since for sure we are not supporting something if we 124 -- bomb). By giving this message, we provide a more reasonable practical 125 -- interface, since giving scary bug boxes on unsupported features is 126 -- 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 From_GCC 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 not From_GCC then 239 240 -- For exception case, get exception message from the TSD. Note 241 -- that it would be neater and cleaner to pass the exception 242 -- message (obtained from Exception_Message) as a parameter to 243 -- Compiler_Abort, but we can't do this quite yet since it would 244 -- cause bootstrap path problems for 3.10 to 3.11. 245 246 Write_Char (' '); 247 Write_Str (Exception_Message (Get_Current_Excep.all.all)); 248 end if; 249 250 End_Line; 251 252 -- Output source location information 253 254 if Sloc (Current_Error_Node) <= No_Location then 255 if Fallback_Loc'Length > 0 then 256 Write_Str ("| Error detected around "); 257 Write_Str (Fallback_Loc); 258 else 259 Write_Str ("| No source file position information available"); 260 end if; 261 262 End_Line; 263 else 264 Write_Str ("| Error detected at "); 265 Write_Location (Sloc (Current_Error_Node)); 266 End_Line; 267 end if; 268 269 -- There are two cases now. If the file gnat_bug.box exists, 270 -- we use the contents of this file at this point. 271 272 declare 273 Lo : Source_Ptr; 274 Hi : Source_Ptr; 275 Src : Source_Buffer_Ptr; 276 277 begin 278 Namet.Unlock; 279 Name_Buffer (1 .. 12) := "gnat_bug.box"; 280 Name_Len := 12; 281 Read_Source_File (Name_Enter, 0, Hi, Src); 282 283 -- If we get a Src file, we use it 284 285 if Src /= null then 286 Lo := 0; 287 288 Outer : while Lo < Hi loop 289 Write_Str ("| "); 290 291 Inner : loop 292 exit Inner when Src (Lo) = ASCII.CR 293 or else Src (Lo) = ASCII.LF; 294 Write_Char (Src (Lo)); 295 Lo := Lo + 1; 296 end loop Inner; 297 298 End_Line; 299 300 while Lo <= Hi 301 and then (Src (Lo) = ASCII.CR 302 or else Src (Lo) = ASCII.LF) 303 loop 304 Lo := Lo + 1; 305 end loop; 306 end loop Outer; 307 308 -- Otherwise we use the standard fixed text 309 310 else 311 if Is_FSF_Version then 312 Write_Str 313 ("| Please submit a bug report; see" & 314 " http://gcc.gnu.org/bugs.html."); 315 End_Line; 316 317 elsif Is_GPL_Version then 318 319 Write_Str 320 ("| Please submit a bug report by email " & 321 "to report@adacore.com."); 322 End_Line; 323 324 Write_Str 325 ("| GAP members can alternatively use GNAT Tracker:"); 326 End_Line; 327 328 Write_Str 329 ("| http://www.adacore.com/ " & 330 "section 'send a report'."); 331 End_Line; 332 333 Write_Str 334 ("| See gnatinfo.txt for full info on procedure " & 335 "for submitting bugs."); 336 End_Line; 337 338 else 339 Write_Str 340 ("| Please submit a bug report using GNAT Tracker:"); 341 End_Line; 342 343 Write_Str 344 ("| http://www.adacore.com/gnattracker/ " & 345 "section 'send a report'."); 346 End_Line; 347 348 Write_Str 349 ("| alternatively submit a bug report by email " & 350 "to report@adacore.com,"); 351 End_Line; 352 353 Write_Str 354 ("| including your customer number #nnn " & 355 "in the subject line."); 356 End_Line; 357 end if; 358 359 Write_Str 360 ("| Use a subject line meaningful to you" & 361 " and us to track the bug."); 362 End_Line; 363 364 Write_Str 365 ("| Include the entire contents of this bug " & 366 "box in the report."); 367 End_Line; 368 369 Write_Str 370 ("| Include the exact gcc or gnatmake command " & 371 "that you entered."); 372 End_Line; 373 374 Write_Str 375 ("| Also include sources listed below in gnatchop format"); 376 End_Line; 377 378 Write_Str 379 ("| (concatenated together with no headers between files)."); 380 End_Line; 381 382 if not Is_FSF_Version then 383 Write_Str 384 ("| Use plain ASCII or MIME attachment."); 385 End_Line; 386 end if; 387 end if; 388 end; 389 390 -- Complete output of bug box 391 392 Write_Char ('+'); 393 Repeat_Char ('=', 76, '+'); 394 Write_Eol; 395 396 if Debug_Flag_3 then 397 Write_Eol; 398 Write_Eol; 399 Print_Tree_Node (Current_Error_Node); 400 Write_Eol; 401 end if; 402 403 Write_Eol; 404 405 Write_Line ("Please include these source files with error report"); 406 Write_Line ("Note that list may not be accurate in some cases, "); 407 Write_Line ("so please double check that the problem can still "); 408 Write_Line ("be reproduced with the set of files listed."); 409 Write_Line ("Consider also -gnatd.n switch (see debug.adb)."); 410 Write_Eol; 411 412 begin 413 Dump_Source_File_Names; 414 415 -- If we blow up trying to print the list of file names, just output 416 -- informative msg and continue. 417 418 exception 419 when others => 420 Write_Str ("list may be incomplete"); 421 end; 422 423 Write_Eol; 424 Set_Standard_Output; 425 426 Tree_Dump; 427 Source_Dump; 428 raise Unrecoverable_Error; 429 end if; 430 end Compiler_Abort; 431 432 ----------------------- 433 -- Delete_SCIL_Files -- 434 ----------------------- 435 436 procedure Delete_SCIL_Files is 437 Main : Node_Id; 438 Unit_Name : Node_Id; 439 440 Success : Boolean; 441 pragma Unreferenced (Success); 442 443 procedure Decode_Name_Buffer; 444 -- Replace "__" by "." in Name_Buffer, and adjust Name_Len accordingly 445 446 ------------------------ 447 -- Decode_Name_Buffer -- 448 ------------------------ 449 450 procedure Decode_Name_Buffer is 451 J : Natural; 452 K : Natural; 453 454 begin 455 J := 1; 456 K := 0; 457 while J <= Name_Len loop 458 K := K + 1; 459 460 if J < Name_Len 461 and then Name_Buffer (J) = '_' 462 and then Name_Buffer (J + 1) = '_' 463 then 464 Name_Buffer (K) := '.'; 465 J := J + 1; 466 else 467 Name_Buffer (K) := Name_Buffer (J); 468 end if; 469 470 J := J + 1; 471 end loop; 472 473 Name_Len := K; 474 end Decode_Name_Buffer; 475 476 -- Start of processing for Delete_SCIL_Files 477 478 begin 479 -- If parsing was not successful, no Main_Unit is available, so return 480 -- immediately. 481 482 if Main_Source_File = No_Source_File then 483 return; 484 end if; 485 486 -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and 487 -- SCIL/<unit>__body.scil, ditto for .scilx files. 488 489 Main := Unit (Cunit (Main_Unit)); 490 491 case Nkind (Main) is 492 when N_Subprogram_Body | N_Package_Declaration => 493 Unit_Name := Defining_Unit_Name (Specification (Main)); 494 495 when N_Package_Body => 496 Unit_Name := Corresponding_Spec (Main); 497 498 when N_Package_Renaming_Declaration => 499 Unit_Name := Defining_Unit_Name (Main); 500 501 -- No SCIL file generated for generic package declarations 502 503 when N_Generic_Package_Declaration => 504 return; 505 506 -- Should never happen, but can be ignored in production 507 508 when others => 509 pragma Assert (False); 510 return; 511 end case; 512 513 case Nkind (Unit_Name) is 514 when N_Defining_Identifier => 515 Get_Name_String (Chars (Unit_Name)); 516 517 when N_Defining_Program_Unit_Name => 518 Get_Name_String (Chars (Defining_Identifier (Unit_Name))); 519 Decode_Name_Buffer; 520 521 -- Should never happen, but can be ignored in production 522 523 when others => 524 pragma Assert (False); 525 return; 526 end case; 527 528 Delete_File 529 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success); 530 Delete_File 531 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success); 532 Delete_File 533 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success); 534 Delete_File 535 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success); 536 end Delete_SCIL_Files; 537 538 ----------------- 539 -- Repeat_Char -- 540 ----------------- 541 542 procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is 543 begin 544 while Column < Col loop 545 Write_Char (Char); 546 end loop; 547 548 Write_Char (After); 549 end Repeat_Char; 550 551end Comperr; 552