gcc/ada/comperr.adb

   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-2023, 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
  30 with Atree;          use Atree;
  31 with Debug;          use Debug;
  32 with Errout;         use Errout;
  33 with Gnatvsn;        use Gnatvsn;
  34 with Lib;            use Lib;
  35 with Namet;          use Namet;
  36 with Opt;            use Opt;
  37 with Osint;          use Osint;
  38 with Output;         use Output;
  39 with Sinfo;          use Sinfo;
  40 with Sinfo.Nodes;    use Sinfo.Nodes;
  41 with Sinput;         use Sinput;
  42 with Sprint;         use Sprint;
  43 with Sdefault;       use Sdefault;
  44 with Treepr;         use Treepr;
  45 with Types;          use Types;
  46
  47 with Ada.Exceptions; use Ada.Exceptions;
  48
  49 with System.OS_Lib;     use System.OS_Lib;
  50 with System.Soft_Links; use System.Soft_Links;
  51
  52 package 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 CodePeer rather than generating a bug box, friendlier.
 120
 121       --  Note that the call to Error_Msg_N below sets Serious_Errors_Detected
 122       --  to 1, so we use the regular mechanism below in order to display a
 123       --  "compilation abandoned" message and exit, so we still know we have
 124       --  this case (and -gnatdk can still be used to get the bug box).
 125
 126       if CodePeer_Mode
 127         and then Serious_Errors_Detected = 0
 128         and then not Debug_Flag_K
 129         and then Sloc (Current_Error_Node) > No_Location
 130       then
 131          Error_Msg_N ("cannot generate 'S'C'I'L", Current_Error_Node);
 132       end if;
 133
 134       --  If we are in CodePeer mode, we must also delete SCIL files
 135
 136       if CodePeer_Mode then
 137          Delete_SCIL_Files;
 138       end if;
 139
 140       --  If any errors have already occurred, then we guess that the abort
 141       --  may well be caused by previous errors, and we don't make too much
 142       --  fuss about it, since we want to let programmer fix the errors first.
 143
 144       --  Debug flag K disables this behavior (useful for debugging)
 145
 146       if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
 147          Errout.Finalize (Last_Call => True);
 148          Errout.Output_Messages;
 149
 150          Set_Standard_Error;
 151          Write_Str ("compilation abandoned due to previous error");
 152          Write_Eol;
 153
 154          Set_Standard_Output;
 155          Source_Dump;
 156          Tree_Dump;
 157          Exit_Program (E_Errors);
 158
 159       --  Otherwise give message with details of the abort
 160
 161       else
 162          Set_Standard_Error;
 163
 164          --  Generate header for bug box
 165
 166          Write_Char ('+');
 167          Repeat_Char ('=', 29, 'G');
 168          Write_Str ("NAT BUG DETECTED");
 169          Repeat_Char ('=', 76, '+');
 170          Write_Eol;
 171
 172          --  Output GNAT version identification
 173
 174          Write_Str ("| ");
 175          Write_Str (Gnat_Version_String);
 176          Write_Str (" (");
 177
 178          --  Output target name, deleting junk final reverse slash
 179
 180          if Target_Name.all (Target_Name.all'Last) = '\'
 181            or else Target_Name.all (Target_Name.all'Last) = '/'
 182          then
 183             Write_Str (Target_Name.all (1 .. Target_Name.all'Last - 1));
 184          else
 185             Write_Str (Target_Name.all);
 186          end if;
 187
 188          --  Output identification of error
 189
 190          Write_Str (") ");
 191
 192          if X'Length + Column > 76 then
 193             if From_GCC then
 194                Write_Str ("GCC error:");
 195             end if;
 196
 197             End_Line;
 198
 199             Write_Str ("| ");
 200          end if;
 201
 202          if X'Length > 70 then
 203             declare
 204                Last_Blank : Integer := 70;
 205
 206             begin
 207                for P in 39 .. 68 loop
 208                   if X (XF + P) = ' ' then
 209                      Last_Blank := P;
 210                   end if;
 211                end loop;
 212
 213                Write_Str (X (XF .. XF - 1 + Last_Blank));
 214                End_Line;
 215                Write_Str ("|    ");
 216                Write_Str (X (XF + Last_Blank .. X'Last));
 217             end;
 218          else
 219             Write_Str (X);
 220          end if;
 221
 222          if not From_GCC then
 223
 224             --  For exception case, get exception message from the TSD. Note
 225             --  that it would be neater and cleaner to pass the exception
 226             --  message (obtained from Exception_Message) as a parameter to
 227             --  Compiler_Abort, but we can't do this quite yet since it would
 228             --  cause bootstrap path problems for 3.10 to 3.11.
 229
 230             Write_Char (' ');
 231             Write_Str (Exception_Message (Get_Current_Excep.all.all));
 232          end if;
 233
 234          End_Line;
 235
 236          --  Output source location information
 237
 238          if Sloc (Current_Error_Node) <= No_Location then
 239             if Fallback_Loc'Length > 0 then
 240                Write_Str ("| Error detected around ");
 241                Write_Str (Fallback_Loc);
 242             else
 243                Write_Str ("| No source file position information available");
 244             end if;
 245
 246             End_Line;
 247
 248          else
 249             Write_Str ("| Error detected at ");
 250             Write_Location (Sloc (Current_Error_Node));
 251             End_Line;
 252          end if;
 253
 254          Write_Str ("| Compiling ");
 255          Write_Str (Get_First_Main_File_Name);
 256          End_Line;
 257
 258          --  There are two cases now. If the file gnat_bug.box exists,
 259          --  we use the contents of this file at this point.
 260
 261          declare
 262             FD  : File_Descriptor;
 263             Lo  : Source_Ptr;
 264             Hi  : Source_Ptr;
 265             Src : Source_Buffer_Ptr;
 266
 267          begin
 268             Namet.Unlock;
 269             Name_Buffer (1 .. 12) := "gnat_bug.box";
 270             Name_Len := 12;
 271             Read_Source_File (Name_Enter, 0, Hi, Src, FD);
 272
 273             --  If we get a Src file, we use it
 274
 275             if not Null_Source_Buffer_Ptr (Src) then
 276                Lo := 0;
 277
 278                Outer : while Lo < Hi loop
 279                   Write_Str ("| ");
 280
 281                   Inner : loop
 282                      exit Inner when Src (Lo) = ASCII.CR
 283                        or else Src (Lo) = ASCII.LF;
 284                      Write_Char (Src (Lo));
 285                      Lo := Lo + 1;
 286                   end loop Inner;
 287
 288                   End_Line;
 289
 290                   while Lo <= Hi
 291                     and then (Src (Lo) = ASCII.CR
 292                                 or else Src (Lo) = ASCII.LF)
 293                   loop
 294                      Lo := Lo + 1;
 295                   end loop;
 296                end loop Outer;
 297
 298             --  Otherwise we use the standard fixed text
 299
 300             else
 301                if Is_FSF_Version then
 302                   Write_Str
 303                     ("| Please submit a bug report; see" &
 304                      " https://gcc.gnu.org/bugs/ .");
 305                   End_Line;
 306
 307                elsif Is_GPL_Version then
 308
 309                   Write_Str
 310                     ("| Please submit a bug report by email " &
 311                      "to report@adacore.com.");
 312                   End_Line;
 313
 314                   Write_Str
 315                     ("| GAP members can alternatively use GNAT Tracker:");
 316                   End_Line;
 317
 318                   Write_Str
 319                     ("| https://www.adacore.com/login?mode=gap " &
 320                      "section 'Create New Ticket'.");
 321                   End_Line;
 322
 323                   Write_Str
 324                     ("| See gnatinfo.txt for full info on procedure " &
 325                      "for submitting bugs.");
 326                   End_Line;
 327
 328                else
 329                   Write_Str
 330                     ("| Please submit a bug report using GNAT Tracker:");
 331                   End_Line;
 332
 333                   Write_Str
 334                     ("| https://www.adacore.com/login " &
 335                      "section 'Create New Ticket'.");
 336                   End_Line;
 337
 338                   Write_Str
 339                     ("| Or submit a bug report by email " &
 340                      "to report@adacore.com");
 341                   End_Line;
 342
 343                   Write_Str
 344                     ("| and include your customer number #nnn " &
 345                      "in the subject line.");
 346                   End_Line;
 347                end if;
 348
 349                Write_Str
 350                  ("| Use a subject line meaningful to you" &
 351                   " and us to track the bug.");
 352                End_Line;
 353
 354                Write_Str
 355                  ("| Include the entire contents of this bug " &
 356                   "box in the report.");
 357                End_Line;
 358
 359                Write_Str
 360                  ("| Include the exact command that you entered.");
 361                End_Line;
 362
 363                Write_Str
 364                  ("| Also include sources listed below.");
 365                End_Line;
 366
 367                if not Is_FSF_Version then
 368                   Write_Str
 369                     ("| Use plain ASCII or MIME attachment(s).");
 370                   End_Line;
 371                end if;
 372             end if;
 373          end;
 374
 375          --  Complete output of bug box
 376
 377          Write_Char ('+');
 378          Repeat_Char ('=', 76, '+');
 379          Write_Eol;
 380
 381          if Debug_Flag_3 then
 382             Write_Eol;
 383             Write_Eol;
 384             Print_Tree_Node (Current_Error_Node);
 385             Write_Eol;
 386          end if;
 387
 388          Write_Eol;
 389
 390          Write_Line ("Please include these source files with error report");
 391          Write_Line ("Note that list may not be accurate in some cases, ");
 392          Write_Line ("so please double check that the problem can still ");
 393          Write_Line ("be reproduced with the set of files listed.");
 394          Write_Line ("Consider also -gnatd.n switch (see debug.adb).");
 395          Write_Eol;
 396
 397          begin
 398             Dump_Source_File_Names;
 399
 400          --  If we blow up trying to print the list of file names, just output
 401          --  informative msg and continue.
 402
 403          exception
 404             when others =>
 405                Write_Str ("list may be incomplete");
 406          end;
 407
 408          Write_Eol;
 409          Set_Standard_Output;
 410
 411          Tree_Dump;
 412          Sinput.Unlock; -- so Source_Dump can modify it
 413          Source_Dump;
 414          raise Unrecoverable_Error;
 415       end if;
 416    end Compiler_Abort;
 417
 418    -----------------------
 419    -- Delete_SCIL_Files --
 420    -----------------------
 421
 422    procedure Delete_SCIL_Files is
 423       Main      : Node_Id;
 424       Unit_Name : Node_Id;
 425
 426       Success : Boolean;
 427       pragma Warnings (Off, "modified by call");
 428
 429       procedure Decode_Name_Buffer;
 430       --  Replace "__" by "." in Name_Buffer, and adjust Name_Len accordingly
 431
 432       ------------------------
 433       -- Decode_Name_Buffer --
 434       ------------------------
 435
 436       procedure Decode_Name_Buffer is
 437          J : Natural;
 438          K : Natural;
 439
 440       begin
 441          J := 1;
 442          K := 0;
 443          while J <= Name_Len loop
 444             K := K + 1;
 445
 446             if J < Name_Len
 447               and then Name_Buffer (J) = '_'
 448               and then Name_Buffer (J + 1) = '_'
 449             then
 450                Name_Buffer (K) := '.';
 451                J := J + 1;
 452             else
 453                Name_Buffer (K) := Name_Buffer (J);
 454             end if;
 455
 456             J := J + 1;
 457          end loop;
 458
 459          Name_Len := K;
 460       end Decode_Name_Buffer;
 461
 462    --  Start of processing for Delete_SCIL_Files
 463
 464    begin
 465       --  If parsing was not successful, no Main_Unit is available, so return
 466       --  immediately.
 467
 468       if Main_Source_File <= No_Source_File then
 469          return;
 470       end if;
 471
 472       --  Retrieve unit name, and remove old versions of SCIL/<unit>.scil and
 473       --  SCIL/<unit>__body.scil, ditto for .scilx files.
 474
 475       Main := Unit (Cunit (Main_Unit));
 476
 477       case Nkind (Main) is
 478          when N_Package_Declaration
 479             | N_Subprogram_Body
 480             | N_Subprogram_Declaration
 481             | N_Subprogram_Renaming_Declaration
 482          =>
 483             Unit_Name := Defining_Unit_Name (Specification (Main));
 484
 485          when N_Package_Body =>
 486             Unit_Name := Corresponding_Spec (Main);
 487
 488          when N_Package_Instantiation
 489             | N_Package_Renaming_Declaration
 490          =>
 491             Unit_Name := Defining_Unit_Name (Main);
 492
 493          --  No SCIL file generated for generic unit declarations
 494
 495          when N_Generic_Declaration
 496             | N_Generic_Renaming_Declaration
 497          =>
 498             return;
 499
 500          --  Should never happen, but can be ignored in production
 501
 502          when others =>
 503             pragma Assert (False);
 504             return;
 505       end case;
 506
 507       case Nkind (Unit_Name) is
 508          when N_Defining_Identifier =>
 509             Get_Name_String (Chars (Unit_Name));
 510
 511          when N_Defining_Program_Unit_Name =>
 512             Get_Name_String (Chars (Defining_Identifier (Unit_Name)));
 513             Decode_Name_Buffer;
 514
 515          --  Should never happen, but can be ignored in production
 516
 517          when others =>
 518             pragma Assert (False);
 519             return;
 520       end case;
 521
 522       Delete_File
 523         ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success);
 524       Delete_File
 525         ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success);
 526       Delete_File
 527         ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success);
 528       Delete_File
 529         ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success);
 530    end Delete_SCIL_Files;
 531
 532    -----------------
 533    -- Repeat_Char --
 534    -----------------
 535
 536    procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
 537    begin
 538       while Column < Col loop
 539          Write_Char (Char);
 540       end loop;
 541
 542       Write_Char (After);
 543    end Repeat_Char;
 544
 545 end Comperr;