1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1991-2007, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Err_Vars
; use Err_Vars
;
27 with Erroutc
; use Erroutc
;
28 with Namet
; use Namet
;
30 with Output
; use Output
;
31 with Scans
; use Scans
;
32 with Sinput
; use Sinput
;
34 package body Errutil
is
36 Errors_Must_Be_Ignored
: Boolean := False;
37 -- Set to True by procedure Set_Ignore_Errors (True), when calls to
38 -- error message procedures should be ignored (when parsing irrelevant
39 -- text in sources being preprocessed).
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 procedure Error_Msg_AP
(Msg
: String);
46 -- Output a message just after the previous token
48 procedure Output_Source_Line
49 (L
: Physical_Line_Number
;
50 Sfile
: Source_File_Index
;
52 Source_Type
: String);
53 -- Outputs text of source line L, in file S, together with preceding line
54 -- number, as described above for Output_Line_Number. The Errs parameter
55 -- indicates if there are errors attached to the line, which forces
56 -- listing on, even in the presence of pragma List (Off).
58 procedure Set_Msg_Insertion_Column
;
59 -- Handle column number insertion (@ insertion character)
61 procedure Set_Msg_Text
(Text
: String; Flag
: Source_Ptr
);
62 -- Add a sequence of characters to the current message. The characters may
63 -- be one of the special insertion characters (see documentation in spec).
64 -- Flag is the location at which the error is to be posted, which is used
65 -- to determine whether or not the # insertion needs a file name. The
66 -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
67 -- Is_Unconditional_Msg are set on return.
73 procedure Error_Msg_AP
(Msg
: String) is
78 -- If we had saved the Scan_Ptr value after scanning the previous
79 -- token, then we would have exactly the right place for putting
80 -- the flag immediately at hand. However, that would add at least
81 -- two instructions to a Scan call *just* to service the possibility
82 -- of an Error_Msg_AP call. So instead we reconstruct that value.
84 -- We have two possibilities, start with Prev_Token_Ptr and skip over
85 -- the current token, which is made harder by the possibility that this
86 -- token may be in error, or start with Token_Ptr and work backwards.
87 -- We used to take the second approach, but it's hard because of
88 -- comments, and harder still because things that look like comments
89 -- can appear inside strings. So now we take the first approach.
91 -- Note: in the case where there is no previous token, Prev_Token_Ptr
92 -- is set to Source_First, which is a reasonable position for the
93 -- error flag in this situation.
98 -- If the previous token is a string literal, we need a special approach
99 -- since there may be white space inside the literal and we don't want
100 -- to stop on that white space.
102 -- Note that it is not worth worrying about special UTF_32 line
103 -- terminator characters in this context, since this is only about
104 -- error recovery anyway.
106 if Prev_Token
= Tok_String_Literal
then
110 if Source
(S1
) = C
then
112 exit when Source
(S1
) /= C
;
113 elsif Source
(S1
) in Line_Terminator
then
118 -- Character literal also needs special handling
120 elsif Prev_Token
= Tok_Char_Literal
then
123 -- Otherwise we search forward for the end of the current token, marked
124 -- by a line terminator, white space, a comment symbol or if we bump
125 -- into the following token (i.e. the current token)
127 -- Note that it is not worth worrying about special UTF_32 line
128 -- terminator characters in this context, since this is only about
129 -- error recovery anyway.
132 while Source
(S1
) not in Line_Terminator
133 and then Source
(S1
) /= ' '
134 and then Source
(S1
) /= ASCII
.HT
135 and then (Source
(S1
) /= '-' or else Source
(S1
+ 1) /= '-')
136 and then S1
/= Token_Ptr
142 -- S1 is now set to the location for the flag
152 procedure Error_Msg
(Msg
: String; Flag_Location
: Source_Ptr
) is
154 Next_Msg
: Error_Msg_Id
;
155 -- Pointer to next message at insertion point
157 Prev_Msg
: Error_Msg_Id
;
158 -- Pointer to previous message at insertion point
160 Sptr
: Source_Ptr
renames Flag_Location
;
161 -- Corresponds to the Sptr value in the error message object
163 Optr
: Source_Ptr
renames Flag_Location
;
164 -- Corresponds to the Optr value in the error message object. Note
165 -- that for this usage, Sptr and Optr always have the same value,
166 -- since we do not have to worry about generic instantiations.
169 if Errors_Must_Be_Ignored
then
173 if Raise_Exception_On_Error
/= 0 then
174 raise Error_Msg_Exception
;
177 Test_Style_Warning_Serious_Msg
(Msg
);
178 Set_Msg_Text
(Msg
, Sptr
);
180 -- Kill continuation if parent message killed
182 if Continuation
and Last_Killed
then
186 -- Return without doing anything if message is killed and this is not
187 -- the first error message. The philosophy is that if we get a weird
188 -- error message and we already have had a message, then we hope the
189 -- weird message is a junk cascaded message
191 -- Immediate return if warning message and warnings are suppressed.
192 -- Note that style messages are not warnings for this purpose.
194 if Is_Warning_Msg
and then Warnings_Suppressed
(Sptr
) then
195 Cur_Msg
:= No_Error_Msg
;
199 -- Otherwise build error message object for new message
201 Errors
.Increment_Last
;
202 Cur_Msg
:= Errors
.Last
;
203 Errors
.Table
(Cur_Msg
).Text
:= new String'(Msg_Buffer (1 .. Msglen));
204 Errors.Table (Cur_Msg).Next := No_Error_Msg;
205 Errors.Table (Cur_Msg).Sptr := Sptr;
206 Errors.Table (Cur_Msg).Optr := Optr;
207 Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr);
208 Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr);
209 Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
210 Errors.Table (Cur_Msg).Style := Is_Style_Msg;
211 Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
212 Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
213 Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
214 Errors.Table (Cur_Msg).Msg_Cont := Continuation;
215 Errors.Table (Cur_Msg).Deleted := False;
217 Prev_Msg := No_Error_Msg;
218 Next_Msg := First_Error_Msg;
220 while Next_Msg /= No_Error_Msg loop
222 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
224 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then
225 exit when Sptr < Errors.Table (Next_Msg).Sptr;
228 Prev_Msg := Next_Msg;
229 Next_Msg := Errors.Table (Next_Msg).Next;
232 -- Now we insert the new message in the error chain. The insertion
233 -- point for the message is after Prev_Msg and before Next_Msg.
235 -- The possible insertion point for the new message is after Prev_Msg
236 -- and before Next_Msg. However, this is where we do a special check
237 -- for redundant parsing messages, defined as messages posted on the
238 -- same line. The idea here is that probably such messages are junk
239 -- from the parser recovering. In full errors mode, we don't do this
240 -- deletion, but otherwise such messages are discarded at this stage.
242 if Prev_Msg /= No_Error_Msg
243 and then Errors.Table (Prev_Msg).Line =
244 Errors.Table (Cur_Msg).Line
245 and then Errors.Table (Prev_Msg).Sfile =
246 Errors.Table (Cur_Msg).Sfile
248 -- Don't delete unconditional messages and at this stage, don't
249 -- delete continuation lines (we attempted to delete those earlier
250 -- if the parent message was deleted.
252 if not Errors.Table (Cur_Msg).Uncond
253 and then not Continuation
256 -- Don't delete if prev msg is warning and new msg is an error.
257 -- This is because we don't want a real error masked by a warning.
258 -- In all other cases (that is parse errors for the same line that
259 -- are not unconditional) we do delete the message. This helps to
260 -- avoid junk extra messages from cascaded parsing errors
262 if not (Errors.Table (Prev_Msg).Warn
264 Errors.Table (Prev_Msg).Style)
266 (Errors.Table (Cur_Msg).Warn
268 Errors.Table (Cur_Msg).Style)
270 -- All tests passed, delete the message by simply returning
271 -- without any further processing.
273 if not Continuation then
282 -- Come here if message is to be inserted in the error chain
284 if not Continuation then
285 Last_Killed := False;
288 if Prev_Msg = No_Error_Msg then
289 First_Error_Msg := Cur_Msg;
291 Errors.Table (Prev_Msg).Next := Cur_Msg;
294 Errors.Table (Cur_Msg).Next := Next_Msg;
296 -- Bump appropriate statistics count
298 if Errors.Table (Cur_Msg).Warn or Errors.Table (Cur_Msg).Style then
299 Warnings_Detected := Warnings_Detected + 1;
301 Total_Errors_Detected := Total_Errors_Detected + 1;
303 if Errors.Table (Cur_Msg).Serious then
304 Serious_Errors_Detected := Serious_Errors_Detected + 1;
314 procedure Error_Msg_S (Msg : String) is
316 Error_Msg (Msg, Scan_Ptr);
323 procedure Error_Msg_SC (Msg : String) is
325 -- If we are at end of file, post the flag after the previous token
327 if Token = Tok_EOF then
330 -- For all other cases the message is posted at the current token
334 Error_Msg (Msg, Token_Ptr);
342 procedure Error_Msg_SP (Msg : String) is
344 -- Note: in the case where there is no previous token, Prev_Token_Ptr
345 -- is set to Source_First, which is a reasonable position for the
346 -- error flag in this situation
348 Error_Msg (Msg, Prev_Token_Ptr);
355 procedure Finalize (Source_Type : String := "project") is
362 -- Eliminate any duplicated error messages from the list. This is
363 -- done after the fact to avoid problems with Change_Error_Text.
365 Cur := First_Error_Msg;
366 while Cur /= No_Error_Msg loop
367 Nxt := Errors.Table (Cur).Next;
370 while F /= No_Error_Msg
371 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
373 Check_Duplicate_Message (Cur, F);
374 F := Errors.Table (F).Next;
382 if Brief_Output or (not Full_List and not Verbose_Mode) then
383 E := First_Error_Msg;
386 while E /= No_Error_Msg loop
387 if not Errors.Table (E).Deleted then
388 if Full_Path_Name_For_Brief_Errors then
389 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
391 Write_Name (Reference_Name (Errors.Table (E).Sfile));
395 Write_Int (Int (Physical_To_Logical
396 (Errors.Table (E).Line,
397 Errors.Table (E).Sfile)));
400 if Errors.Table (E).Col < 10 then
404 Write_Int (Int (Errors.Table (E).Col));
410 E := Errors.Table (E).Next;
416 -- Full source listing case
419 List_Pragmas_Index := 1;
420 List_Pragmas_Mode := True;
421 E := First_Error_Msg;
424 -- First list initial main source file with its error messages
426 for N in 1 .. Last_Source_Line (Main_Source_File) loop
429 and then Errors.Table (E).Line = N
430 and then Errors.Table (E).Sfile = Main_Source_File;
432 Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type);
435 Output_Error_Msgs (E);
441 -- Then output errors, if any, for subsidiary units
443 while E /= No_Error_Msg
444 and then Errors.Table (E).Sfile /= Main_Source_File
448 (Errors.Table (E).Line,
449 Errors.Table (E).Sfile,
452 Output_Error_Msgs (E);
456 -- Verbose mode (error lines only with error flags)
459 E := First_Error_Msg;
461 -- Loop through error lines
463 while E /= No_Error_Msg loop
466 (Errors.Table (E).Line,
467 Errors.Table (E).Sfile,
470 Output_Error_Msgs (E);
474 -- Output error summary if verbose or full list mode
476 if Verbose_Mode or else Full_List then
478 -- Extra blank line if error messages or source listing were output
480 if Total_Errors_Detected + Warnings_Detected > 0
486 -- Message giving number of lines read and number of errors detected.
487 -- This normally goes to Standard_Output. The exception is when brief
488 -- mode is not set, verbose mode (or full list mode) is set, and
489 -- there are errors. In this case we send the message to standard
490 -- error to make sure that *something* appears on standard error in
491 -- an error situation.
493 -- Formerly, only the "# errors" suffix was sent to stderr, whereas
494 -- "# lines:" appeared on stdout. This caused problems on VMS when
495 -- the stdout buffer was flushed, giving an extra line feed after
498 if Total_Errors_Detected + Warnings_Detected /= 0
499 and then not Brief_Output
500 and then (Verbose_Mode or Full_List)
505 -- Message giving total number of lines
508 Write_Int (Num_Source_Lines (Main_Source_File));
510 if Num_Source_Lines (Main_Source_File) = 1 then
511 Write_Str (" line: ");
513 Write_Str (" lines: ");
516 if Total_Errors_Detected = 0 then
517 Write_Str ("No errors");
519 elsif Total_Errors_Detected = 1 then
520 Write_Str ("1 error");
523 Write_Int (Total_Errors_Detected);
524 Write_Str (" errors");
527 if Warnings_Detected /= 0 then
529 Write_Int (Warnings_Detected);
530 Write_Str (" warning");
532 if Warnings_Detected /= 1 then
536 if Warning_Mode = Treat_As_Error then
537 Write_Str (" (treated as error");
539 if Warnings_Detected /= 1 then
551 if Maximum_Errors /= 0
552 and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
555 Write_Str ("fatal error: maximum errors reached");
560 if Warning_Mode = Treat_As_Error then
561 Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
562 Warnings_Detected := 0;
570 procedure Initialize is
573 First_Error_Msg := No_Error_Msg;
574 Last_Error_Msg := No_Error_Msg;
575 Serious_Errors_Detected := 0;
576 Total_Errors_Detected := 0;
577 Warnings_Detected := 0;
578 Cur_Msg := No_Error_Msg;
580 -- Initialize warnings table, if all warnings are suppressed, supply
581 -- an initial dummy entry covering all possible source locations.
585 if Warning_Mode = Suppress then
586 Warnings.Increment_Last;
587 Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
588 Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
592 ------------------------
593 -- Output_Source_Line --
594 ------------------------
596 procedure Output_Source_Line
597 (L : Physical_Line_Number;
598 Sfile : Source_File_Index;
600 Source_Type : String)
605 Line_Number_Output : Boolean := False;
606 -- Set True once line number is output
609 if Sfile /= Current_Error_Source_File then
610 Write_Str ("==============Error messages for ");
611 Write_Str (Source_Type);
612 Write_Str (" file: ");
613 Write_Name (Full_File_Name (Sfile));
615 Current_Error_Source_File := Sfile;
619 Output_Line_Number (Physical_To_Logical (L, Sfile));
620 Line_Number_Output := True;
623 S := Line_Start (L, Sfile);
626 C := Source_Text (Sfile) (S);
627 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
636 if Line_Number_Output then
639 end Output_Source_Line;
641 -----------------------
642 -- Set_Ignore_Errors --
643 -----------------------
645 procedure Set_Ignore_Errors (To : Boolean) is
647 Errors_Must_Be_Ignored := To;
648 end Set_Ignore_Errors;
650 ------------------------------
651 -- Set_Msg_Insertion_Column --
652 ------------------------------
654 procedure Set_Msg_Insertion_Column is
656 if Style.RM_Column_Check then
657 Set_Msg_Str (" in column ");
658 Set_Msg_Int (Int (Error_Msg_Col) + 1);
660 end Set_Msg_Insertion_Column;
666 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
667 C : Character; -- Current character
668 P : Natural; -- Current index;
671 Manual_Quote_Mode := False;
673 Flag_Source := Get_Source_File_Index (Flag);
676 while P <= Text'Last loop
680 -- Check for insertion character
683 if P <= Text'Last and then Text (P) = '%' then
685 Set_Msg_Insertion_Name_Literal;
687 Set_Msg_Insertion_Name;
697 Set_Msg_Insertion_File_Name;
706 Set_Msg_Insertion_Reserved_Name;
715 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
718 Continuation := True;
721 Set_Msg_Insertion_Column;
724 Set_Msg_Insertion_Uint;
727 Manual_Quote_Mode := not Manual_Quote_Mode;
731 Is_Unconditional_Msg := True;
743 Set_Msg_Char (Text (P));
746 -- Upper case letter (start of reserved word if 2 or more)
748 elsif C in 'A' .. 'Z'
749 and then P <= Text'Last
750 and then Text (P) in 'A' .. 'Z'
753 Set_Msg_Insertion_Reserved_Word (Text, P);
755 -- Normal character with no special treatment