|
111
|
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 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 return;
|
|
|
489
|
|
|
490 -- Should never happen, but can be ignored in production
|
|
|
491
|
|
|
492 when others =>
|
|
|
493 pragma Assert (False);
|
|
|
494 return;
|
|
|
495 end case;
|
|
|
496
|
|
|
497 case Nkind (Unit_Name) is
|
|
|
498 when N_Defining_Identifier =>
|
|
|
499 Get_Name_String (Chars (Unit_Name));
|
|
|
500
|
|
|
501 when N_Defining_Program_Unit_Name =>
|
|
|
502 Get_Name_String (Chars (Defining_Identifier (Unit_Name)));
|
|
|
503 Decode_Name_Buffer;
|
|
|
504
|
|
|
505 -- Should never happen, but can be ignored in production
|
|
|
506
|
|
|
507 when others =>
|
|
|
508 pragma Assert (False);
|
|
|
509 return;
|
|
|
510 end case;
|
|
|
511
|
|
|
512 Delete_File
|
|
|
513 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success);
|
|
|
514 Delete_File
|
|
|
515 ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scilx", Success);
|
|
|
516 Delete_File
|
|
|
517 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success);
|
|
|
518 Delete_File
|
|
|
519 ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scilx", Success);
|
|
|
520 end Delete_SCIL_Files;
|
|
|
521
|
|
|
522 -----------------
|
|
|
523 -- Repeat_Char --
|
|
|
524 -----------------
|
|
|
525
|
|
|
526 procedure Repeat_Char (Char : Character; Col : Nat; After : Character) is
|
|
|
527 begin
|
|
|
528 while Column < Col loop
|
|
|
529 Write_Char (Char);
|
|
|
530 end loop;
|
|
|
531
|
|
|
532 Write_Char (After);
|
|
|
533 end Repeat_Char;
|
|
|
534
|
|
|
535 end Comperr;
|
