File : 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-2016, 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 Sinput; use Sinput;
41 with Sprint; use Sprint;
42 with Sdefault; use Sdefault;
43 with Treepr; use Treepr;
44 with Types; use Types;
45
46 with Ada.Exceptions; use Ada.Exceptions;
47
48 with System.OS_Lib; use System.OS_Lib;
49 with System.Soft_Links; use System.Soft_Links;
50
51 package 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_Package_Declaration |
471 N_Subprogram_Body |
472 N_Subprogram_Declaration =>
473 Unit_Name := Defining_Unit_Name (Specification (Main));
474
475 when N_Package_Body =>
476 Unit_Name := Corresponding_Spec (Main);
477
478 when N_Package_Renaming_Declaration =>
479 Unit_Name := Defining_Unit_Name (Main);
480
481 -- No SCIL file generated for generic package declarations
482
483 when N_Generic_Package_Declaration =>
484 return;
485
486 -- Should never happen, but can be ignored in production
487
488 when others =>
489 pragma Assert (False);
490 return;
491 end case;
492
493 case Nkind (Unit_Name) is
494 when N_Defining_Identifier =>
495 Get_Name_String (Chars (Unit_Name));
496
497 when N_Defining_Program_Unit_Name =>
498 Get_Name_String (Chars (Defining_Identifier (Unit_Name)));
499 Decode_Name_Buffer;
500
501 -- Should never happen, but can be ignored in production
502
503 when others =>
504 pragma Assert (False);
505 return;
506 end case;
507
508 Delete_File
509 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success);
510 Delete_File
511 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success);
512 Delete_File
513 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success);
514 Delete_File
515 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success);
516 end Delete_SCIL_Files;
517
518 -----------------
519 -- Repeat_Char --
520 -----------------
521
522 procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
523 begin
524 while Column < Col loop
525 Write_Char (Char);
526 end loop;
527
528 Write_Char (After);
529 end Repeat_Char;
530
531 end Comperr;