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-2019, 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 FD : File_Descriptor; 257 Lo : Source_Ptr; 258 Hi : Source_Ptr; 259 Src : Source_Buffer_Ptr; 260 261 begin 262 Namet.Unlock; 263 Name_Buffer (1 .. 12) := "gnat_bug.box"; 264 Name_Len := 12; 265 Read_Source_File (Name_Enter, 0, Hi, Src, FD); 266 267 -- If we get a Src file, we use it 268 269 if not Null_Source_Buffer_Ptr (Src) then 270 Lo := 0; 271 272 Outer : while Lo < Hi loop 273 Write_Str ("| "); 274 275 Inner : loop 276 exit Inner when Src (Lo) = ASCII.CR 277 or else Src (Lo) = ASCII.LF; 278 Write_Char (Src (Lo)); 279 Lo := Lo + 1; 280 end loop Inner; 281 282 End_Line; 283 284 while Lo <= Hi 285 and then (Src (Lo) = ASCII.CR 286 or else Src (Lo) = ASCII.LF) 287 loop 288 Lo := Lo + 1; 289 end loop; 290 end loop Outer; 291 292 -- Otherwise we use the standard fixed text 293 294 else 295 if Is_FSF_Version then 296 Write_Str 297 ("| Please submit a bug report; see" & 298 " https://gcc.gnu.org/bugs/ ."); 299 End_Line; 300 301 elsif Is_GPL_Version then 302 303 Write_Str 304 ("| Please submit a bug report by email " & 305 "to report@adacore.com."); 306 End_Line; 307 308 Write_Str 309 ("| GAP members can alternatively use GNAT Tracker:"); 310 End_Line; 311 312 Write_Str 313 ("| http://www.adacore.com/ " & 314 "section 'send a report'."); 315 End_Line; 316 317 Write_Str 318 ("| See gnatinfo.txt for full info on procedure " & 319 "for submitting bugs."); 320 End_Line; 321 322 else 323 Write_Str 324 ("| Please submit a bug report using GNAT Tracker:"); 325 End_Line; 326 327 Write_Str 328 ("| http://www.adacore.com/gnattracker/ " & 329 "section 'send a report'."); 330 End_Line; 331 332 Write_Str 333 ("| alternatively submit a bug report by email " & 334 "to report@adacore.com,"); 335 End_Line; 336 337 Write_Str 338 ("| including your customer number #nnn " & 339 "in the subject line."); 340 End_Line; 341 end if; 342 343 Write_Str 344 ("| Use a subject line meaningful to you" & 345 " and us to track the bug."); 346 End_Line; 347 348 Write_Str 349 ("| Include the entire contents of this bug " & 350 "box in the report."); 351 End_Line; 352 353 Write_Str 354 ("| Include the exact command that you entered."); 355 End_Line; 356 357 Write_Str 358 ("| Also include sources listed below."); 359 End_Line; 360 361 if not Is_FSF_Version then 362 Write_Str 363 ("| Use plain ASCII or MIME attachment(s)."); 364 End_Line; 365 end if; 366 end if; 367 end; 368 369 -- Complete output of bug box 370 371 Write_Char ('+'); 372 Repeat_Char ('=', 76, '+'); 373 Write_Eol; 374 375 if Debug_Flag_3 then 376 Write_Eol; 377 Write_Eol; 378 Print_Tree_Node (Current_Error_Node); 379 Write_Eol; 380 end if; 381 382 Write_Eol; 383 384 Write_Line ("Please include these source files with error report"); 385 Write_Line ("Note that list may not be accurate in some cases, "); 386 Write_Line ("so please double check that the problem can still "); 387 Write_Line ("be reproduced with the set of files listed."); 388 Write_Line ("Consider also -gnatd.n switch (see debug.adb)."); 389 Write_Eol; 390 391 begin 392 Dump_Source_File_Names; 393 394 -- If we blow up trying to print the list of file names, just output 395 -- informative msg and continue. 396 397 exception 398 when others => 399 Write_Str ("list may be incomplete"); 400 end; 401 402 Write_Eol; 403 Set_Standard_Output; 404 405 Tree_Dump; 406 Source_Dump; 407 raise Unrecoverable_Error; 408 end if; 409 end Compiler_Abort; 410 411 ----------------------- 412 -- Delete_SCIL_Files -- 413 ----------------------- 414 415 procedure Delete_SCIL_Files is 416 Main : Node_Id; 417 Unit_Name : Node_Id; 418 419 Success : Boolean; 420 pragma Unreferenced (Success); 421 422 procedure Decode_Name_Buffer; 423 -- Replace "__" by "." in Name_Buffer, and adjust Name_Len accordingly 424 425 ------------------------ 426 -- Decode_Name_Buffer -- 427 ------------------------ 428 429 procedure Decode_Name_Buffer is 430 J : Natural; 431 K : Natural; 432 433 begin 434 J := 1; 435 K := 0; 436 while J <= Name_Len loop 437 K := K + 1; 438 439 if J < Name_Len 440 and then Name_Buffer (J) = '_' 441 and then Name_Buffer (J + 1) = '_' 442 then 443 Name_Buffer (K) := '.'; 444 J := J + 1; 445 else 446 Name_Buffer (K) := Name_Buffer (J); 447 end if; 448 449 J := J + 1; 450 end loop; 451 452 Name_Len := K; 453 end Decode_Name_Buffer; 454 455 -- Start of processing for Delete_SCIL_Files 456 457 begin 458 -- If parsing was not successful, no Main_Unit is available, so return 459 -- immediately. 460 461 if Main_Source_File <= No_Source_File then 462 return; 463 end if; 464 465 -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and 466 -- SCIL/<unit>__body.scil, ditto for .scilx files. 467 468 Main := Unit (Cunit (Main_Unit)); 469 470 case Nkind (Main) is 471 when N_Package_Declaration 472 | N_Subprogram_Body 473 | N_Subprogram_Declaration 474 => 475 Unit_Name := Defining_Unit_Name (Specification (Main)); 476 477 when N_Package_Body => 478 Unit_Name := Corresponding_Spec (Main); 479 480 when N_Package_Instantiation 481 | N_Package_Renaming_Declaration 482 => 483 Unit_Name := Defining_Unit_Name (Main); 484 485 -- No SCIL file generated for generic package declarations 486 487 when N_Generic_Package_Declaration 488 | N_Generic_Package_Renaming_Declaration 489 => 490 return; 491 492 -- Should never happen, but can be ignored in production 493 494 when others => 495 pragma Assert (False); 496 return; 497 end case; 498 499 case Nkind (Unit_Name) is 500 when N_Defining_Identifier => 501 Get_Name_String (Chars (Unit_Name)); 502 503 when N_Defining_Program_Unit_Name => 504 Get_Name_String (Chars (Defining_Identifier (Unit_Name))); 505 Decode_Name_Buffer; 506 507 -- Should never happen, but can be ignored in production 508 509 when others => 510 pragma Assert (False); 511 return; 512 end case; 513 514 Delete_File 515 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success); 516 Delete_File 517 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success); 518 Delete_File 519 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success); 520 Delete_File 521 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success); 522 end Delete_SCIL_Files; 523 524 ----------------- 525 -- Repeat_Char -- 526 ----------------- 527 528 procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is 529 begin 530 while Column < Col loop 531 Write_Char (Char); 532 end loop; 533 534 Write_Char (After); 535 end Repeat_Char; 536 537end Comperr; 538