1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1991-2023, 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 Atree
; use Atree
;
27 with Err_Vars
; use Err_Vars
;
28 with Erroutc
; use Erroutc
;
29 with Namet
; use Namet
;
31 with Output
; use Output
;
32 with Scans
; use Scans
;
33 with Sinput
; use Sinput
;
34 with Stringt
; use Stringt
;
35 with Stylesw
; use Stylesw
;
37 package body Errutil
is
39 Errors_Must_Be_Ignored
: Boolean := False;
40 -- Set to True by procedure Set_Ignore_Errors (True), when calls to
41 -- error message procedures should be ignored (when parsing irrelevant
42 -- text in sources being preprocessed).
44 -----------------------
45 -- Local Subprograms --
46 -----------------------
48 procedure Error_Msg_AP
(Msg
: String);
49 -- Output a message just after the previous token
51 procedure Output_Source_Line
52 (L
: Physical_Line_Number
;
53 Sfile
: Source_File_Index
;
55 Source_Type
: String);
56 -- Outputs text of source line L, in file S, together with preceding line
57 -- number, as described above for Output_Line_Number. The Errs parameter
58 -- indicates if there are errors attached to the line, which forces
59 -- listing on, even in the presence of pragma List (Off).
61 procedure Set_Msg_Insertion_Column
;
62 -- Handle column number insertion (@ insertion character)
64 procedure Set_Msg_Text
(Text
: String; Flag
: Source_Ptr
);
65 -- Add a sequence of characters to the current message. The characters may
66 -- be one of the special insertion characters (see documentation in spec).
67 -- Flag is the location at which the error is to be posted, which is used
68 -- to determine whether or not the # insertion needs a file name. The
69 -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
70 -- Is_Unconditional_Msg are set on return.
76 procedure Error_Msg_AP
(Msg
: String) is
81 -- If we had saved the Scan_Ptr value after scanning the previous
82 -- token, then we would have exactly the right place for putting
83 -- the flag immediately at hand. However, that would add at least
84 -- two instructions to a Scan call *just* to service the possibility
85 -- of an Error_Msg_AP call. So instead we reconstruct that value.
87 -- We have two possibilities, start with Prev_Token_Ptr and skip over
88 -- the current token, which is made harder by the possibility that this
89 -- token may be in error, or start with Token_Ptr and work backwards.
90 -- We used to take the second approach, but it's hard because of
91 -- comments, and harder still because things that look like comments
92 -- can appear inside strings. So now we take the first approach.
94 -- Note: in the case where there is no previous token, Prev_Token_Ptr
95 -- is set to Source_First, which is a reasonable position for the
96 -- error flag in this situation.
101 -- If the previous token is a string literal, we need a special approach
102 -- since there may be white space inside the literal and we don't want
103 -- to stop on that white space.
105 -- Note that it is not worth worrying about special UTF_32 line
106 -- terminator characters in this context, since this is only about
107 -- error recovery anyway.
109 if Prev_Token
= Tok_String_Literal
then
113 if Source
(S1
) = C
then
115 exit when Source
(S1
) /= C
;
116 elsif Source
(S1
) in Line_Terminator
then
121 -- Character literal also needs special handling
123 elsif Prev_Token
= Tok_Char_Literal
then
126 -- Otherwise we search forward for the end of the current token, marked
127 -- by a line terminator, white space, a comment symbol or if we bump
128 -- into the following token (i.e. the current token)
130 -- Note that it is not worth worrying about special UTF_32 line
131 -- terminator characters in this context, since this is only about
132 -- error recovery anyway.
135 while Source
(S1
) not in Line_Terminator
136 and then Source
(S1
) /= ' '
137 and then Source
(S1
) /= ASCII
.HT
138 and then (Source
(S1
) /= '-' or else Source
(S1
+ 1) /= '-')
139 and then S1
/= Token_Ptr
145 -- S1 is now set to the location for the flag
155 procedure Error_Msg
(Msg
: String; Flag_Location
: Source_Ptr
) is
157 Next_Msg
: Error_Msg_Id
;
158 -- Pointer to next message at insertion point
160 Prev_Msg
: Error_Msg_Id
;
161 -- Pointer to previous message at insertion point
163 Sptr
: Source_Ptr
renames Flag_Location
;
164 -- Corresponds to the Sptr value in the error message object
166 Optr
: Source_Ptr
renames Flag_Location
;
167 -- Corresponds to the Optr value in the error message object. Note that
168 -- for this usage, Sptr and Optr always have the same value, since we do
169 -- not have to worry about generic instantiations.
172 if Errors_Must_Be_Ignored
then
176 if Raise_Exception_On_Error
/= 0 then
177 raise Error_Msg_Exception
;
180 Prescan_Message
(Msg
);
181 Set_Msg_Text
(Msg
, Sptr
);
183 -- Kill continuation if parent message killed
185 if Continuation
and Last_Killed
then
189 -- Return without doing anything if message is killed and this is not
190 -- the first error message. The philosophy is that if we get a weird
191 -- error message and we already have had a message, then we hope the
192 -- weird message is a junk cascaded message
194 -- Immediate return if warning message and warnings are suppressed.
195 -- Note that style messages are not warnings for this purpose.
197 if Is_Warning_Msg
and then Warnings_Suppressed
(Sptr
) /= No_String
then
198 Cur_Msg
:= No_Error_Msg
;
202 -- Otherwise build error message object for new message
206 (Text
=> new String'(Msg_Buffer (1 .. Msglen)),
207 Next => No_Error_Msg,
208 Prev => No_Error_Msg,
209 Sfile => Get_Source_File_Index (Sptr),
210 Sptr => To_Span (Sptr),
211 Optr => To_Span (Optr),
212 Insertion_Sloc => No_Location,
213 Line => Get_Physical_Line_Number (Sptr),
214 Col => Get_Column_Number (Sptr),
215 Compile_Time_Pragma => Is_Compile_Time_Msg,
216 Warn => Is_Warning_Msg,
218 Check => Is_Check_Msg,
219 Warn_Err => Warning_Mode = Treat_As_Error,
220 Warn_Runtime_Raise => Is_Runtime_Raise,
221 Warn_Chr => Warning_Msg_Char,
222 Style => Is_Style_Msg,
223 Serious => Is_Serious_Error,
224 Uncond => Is_Unconditional_Msg,
225 Msg_Cont => Continuation,
229 Cur_Msg := Errors.Last;
230 Prev_Msg := No_Error_Msg;
231 Next_Msg := First_Error_Msg;
233 while Next_Msg /= No_Error_Msg loop
235 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
237 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then
238 exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr;
241 Prev_Msg := Next_Msg;
242 Next_Msg := Errors.Table (Next_Msg).Next;
245 -- Now we insert the new message in the error chain. The insertion
246 -- point for the message is after Prev_Msg and before Next_Msg.
248 -- The possible insertion point for the new message is after Prev_Msg
249 -- and before Next_Msg. However, this is where we do a special check
250 -- for redundant parsing messages, defined as messages posted on the
251 -- same line. The idea here is that probably such messages are junk
252 -- from the parser recovering. In full errors mode, we don't do this
253 -- deletion, but otherwise such messages are discarded at this stage.
255 if Prev_Msg /= No_Error_Msg
256 and then Errors.Table (Prev_Msg).Line =
257 Errors.Table (Cur_Msg).Line
258 and then Errors.Table (Prev_Msg).Sfile =
259 Errors.Table (Cur_Msg).Sfile
261 -- Don't delete unconditional messages and at this stage, don't
262 -- delete continuation lines (we attempted to delete those earlier
263 -- if the parent message was deleted.
265 if not Errors.Table (Cur_Msg).Uncond
266 and then not Continuation
269 -- Don't delete if prev msg is warning and new msg is an error.
270 -- This is because we don't want a real error masked by a warning.
271 -- In all other cases (that is parse errors for the same line that
272 -- are not unconditional) we do delete the message. This helps to
273 -- avoid junk extra messages from cascaded parsing errors
275 if not (Errors.Table (Prev_Msg).Warn
277 Errors.Table (Prev_Msg).Style)
279 (Errors.Table (Cur_Msg).Warn
281 Errors.Table (Cur_Msg).Style)
283 -- All tests passed, delete the message by simply returning
284 -- without any further processing.
286 if not Continuation then
295 -- Come here if message is to be inserted in the error chain
297 if not Continuation then
298 Last_Killed := False;
301 if Prev_Msg = No_Error_Msg then
302 First_Error_Msg := Cur_Msg;
304 Errors.Table (Prev_Msg).Next := Cur_Msg;
307 Errors.Table (Cur_Msg).Next := Next_Msg;
309 -- Bump appropriate statistics counts
311 if Errors.Table (Cur_Msg).Info then
313 -- Could be (usually is) both "info" and "warning"
315 if Errors.Table (Cur_Msg).Warn then
316 Warning_Info_Messages := Warning_Info_Messages + 1;
317 Warnings_Detected := Warnings_Detected + 1;
319 Report_Info_Messages := Report_Info_Messages + 1;
322 elsif Errors.Table (Cur_Msg).Warn
323 or else Errors.Table (Cur_Msg).Style
325 Warnings_Detected := Warnings_Detected + 1;
327 elsif Errors.Table (Cur_Msg).Check then
328 Check_Messages := Check_Messages + 1;
331 Total_Errors_Detected := Total_Errors_Detected + 1;
333 if Errors.Table (Cur_Msg).Serious then
334 Serious_Errors_Detected := Serious_Errors_Detected + 1;
344 procedure Error_Msg_S (Msg : String) is
346 Error_Msg (Msg, Scan_Ptr);
353 procedure Error_Msg_SC (Msg : String) is
355 -- If we are at end of file, post the flag after the previous token
357 if Token = Tok_EOF then
360 -- For all other cases the message is posted at the current token
364 Error_Msg (Msg, Token_Ptr);
372 procedure Error_Msg_SP (Msg : String) is
374 -- Note: in the case where there is no previous token, Prev_Token_Ptr
375 -- is set to Source_First, which is a reasonable position for the
376 -- error flag in this situation
378 Error_Msg (Msg, Prev_Token_Ptr);
385 procedure Finalize (Source_Type : String := "project") is
392 -- Eliminate any duplicated error messages from the list. This is
393 -- done after the fact to avoid problems with Change_Error_Text.
395 Cur := First_Error_Msg;
396 while Cur /= No_Error_Msg loop
397 Nxt := Errors.Table (Cur).Next;
400 while F /= No_Error_Msg
401 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
403 Check_Duplicate_Message (Cur, F);
404 F := Errors.Table (F).Next;
412 if Brief_Output or (not Full_List and not Verbose_Mode) then
413 E := First_Error_Msg;
416 while E /= No_Error_Msg loop
417 if not Errors.Table (E).Deleted then
418 if Full_Path_Name_For_Brief_Errors then
419 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
421 Write_Name (Reference_Name (Errors.Table (E).Sfile));
425 Write_Int (Int (Physical_To_Logical
426 (Errors.Table (E).Line,
427 Errors.Table (E).Sfile)));
430 if Errors.Table (E).Col < 10 then
434 Write_Int (Int (Errors.Table (E).Col));
440 E := Errors.Table (E).Next;
446 -- Full source listing case
449 List_Pragmas_Index := 1;
450 List_Pragmas_Mode := True;
451 E := First_Error_Msg;
454 -- First list initial main source file with its error messages
456 for N in 1 .. Last_Source_Line (Main_Source_File) loop
459 and then Errors.Table (E).Line = N
460 and then Errors.Table (E).Sfile = Main_Source_File;
462 Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type);
465 Output_Error_Msgs (E);
471 -- Then output errors, if any, for subsidiary units
473 while E /= No_Error_Msg
474 and then Errors.Table (E).Sfile /= Main_Source_File
478 (Errors.Table (E).Line,
479 Errors.Table (E).Sfile,
482 Output_Error_Msgs (E);
486 -- Verbose mode (error lines only with error flags)
489 E := First_Error_Msg;
491 -- Loop through error lines
493 while E /= No_Error_Msg loop
496 (Errors.Table (E).Line,
497 Errors.Table (E).Sfile,
500 Output_Error_Msgs (E);
504 -- Output error summary if verbose or full list mode
506 if Verbose_Mode or else Full_List then
508 -- Extra blank line if error messages or source listing were output
510 if Total_Errors_Detected + Warnings_Detected > 0
516 -- Message giving number of lines read and number of errors detected.
517 -- This normally goes to Standard_Output. The exception is when brief
518 -- mode is not set, verbose mode (or full list mode) is set, and
519 -- there are errors. In this case we send the message to standard
520 -- error to make sure that *something* appears on standard error in
521 -- an error situation.
523 -- Historical note: Formerly, only the "# errors" suffix was sent
524 -- to stderr, whereas "# lines:" appeared on stdout. This caused
525 -- some problems on now-obsolete ports, but there seems to be no
526 -- reason to revert this page since it would be incompatible.
528 if Total_Errors_Detected + Warnings_Detected /= 0
529 and then not Brief_Output
530 and then (Verbose_Mode or Full_List)
535 -- Message giving total number of lines
538 Write_Int (Num_Source_Lines (Main_Source_File));
540 if Num_Source_Lines (Main_Source_File) = 1 then
541 Write_Str (" line: ");
543 Write_Str (" lines: ");
546 if Total_Errors_Detected = 0 then
547 Write_Str ("No errors");
549 elsif Total_Errors_Detected = 1 then
550 Write_Str ("1 error");
553 Write_Int (Total_Errors_Detected);
554 Write_Str (" errors");
557 if Warnings_Detected - Warning_Info_Messages /= 0 then
559 Write_Int (Warnings_Detected - Warning_Info_Messages);
560 Write_Str (" warning");
562 if Warnings_Detected - Warning_Info_Messages /= 1 then
566 if Warning_Mode = Treat_As_Error then
567 Write_Str (" (treated as error");
569 if Warnings_Detected - Warning_Info_Messages /= 1 then
581 if Maximum_Messages /= 0 then
582 if Warnings_Detected >= Maximum_Messages then
584 Write_Line ("maximum number of warnings detected");
585 Warning_Mode := Suppress;
588 if Total_Errors_Detected >= Maximum_Messages then
590 Write_Line ("fatal error: maximum errors reached");
595 -- Even though Warning_Info_Messages are a subclass of warnings, they
596 -- must not be treated as errors when -gnatwe is in effect.
598 if Warning_Mode = Treat_As_Error then
599 Total_Errors_Detected :=
600 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
601 Warnings_Detected := Warning_Info_Messages;
604 -- Prevent displaying the same messages again in the future
606 First_Error_Msg := No_Error_Msg;
613 procedure Initialize is
616 First_Error_Msg := No_Error_Msg;
617 Last_Error_Msg := No_Error_Msg;
618 Serious_Errors_Detected := 0;
619 Total_Errors_Detected := 0;
620 Warnings_Detected := 0;
621 Warning_Info_Messages := 0;
622 Report_Info_Messages := 0;
623 Cur_Msg := No_Error_Msg;
625 -- Initialize warnings table, if all warnings are suppressed, supply
626 -- an initial dummy entry covering all possible source locations.
630 if Warning_Mode = Suppress then
633 (Start => Source_Ptr'First,
634 Stop => Source_Ptr'Last,
635 Reason => Null_String_Id));
639 ------------------------
640 -- Output_Source_Line --
641 ------------------------
643 procedure Output_Source_Line
644 (L : Physical_Line_Number;
645 Sfile : Source_File_Index;
647 Source_Type : String)
652 Line_Number_Output : Boolean := False;
653 -- Set True once line number is output
656 if Sfile /= Current_Error_Source_File then
657 Write_Str ("==============Error messages for ");
658 Write_Str (Source_Type);
659 Write_Str (" file: ");
660 Write_Name (Full_File_Name (Sfile));
662 Current_Error_Source_File := Sfile;
666 Output_Line_Number (Physical_To_Logical (L, Sfile));
667 Line_Number_Output := True;
670 S := Line_Start (L, Sfile);
673 C := Source_Text (Sfile) (S);
674 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
683 if Line_Number_Output then
686 end Output_Source_Line;
688 -----------------------
689 -- Set_Ignore_Errors --
690 -----------------------
692 procedure Set_Ignore_Errors (To : Boolean) is
694 Errors_Must_Be_Ignored := To;
695 end Set_Ignore_Errors;
697 ------------------------------
698 -- Set_Msg_Insertion_Column --
699 ------------------------------
701 procedure Set_Msg_Insertion_Column is
703 if RM_Column_Check then
704 Set_Msg_Str (" in column ");
705 Set_Msg_Int (Int (Error_Msg_Col) + 1);
707 end Set_Msg_Insertion_Column;
713 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
714 C : Character; -- Current character
715 P : Natural; -- Current index;
718 Manual_Quote_Mode := False;
720 Flag_Source := Get_Source_File_Index (Flag);
723 while P <= Text'Last loop
727 -- Check for insertion character
730 if P <= Text'Last and then Text (P) = '%' then
732 Set_Msg_Insertion_Name_Literal;
734 Set_Msg_Insertion_Name;
744 Set_Msg_Insertion_File_Name;
753 Set_Msg_Insertion_Reserved_Name;
762 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
765 Continuation := True;
768 Set_Msg_Insertion_Column;
771 Set_Msg_Insertion_Uint;
774 Manual_Quote_Mode := not Manual_Quote_Mode;
790 Set_Msg_Char (Text (P));
793 -- Upper case letter (start of reserved word if 2 or more)
795 elsif C in 'A' .. 'Z'
796 and then P <= Text'Last
797 and then Text (P) in 'A' .. 'Z'
800 Set_Msg_Insertion_Reserved_Word (Text, P);
803 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
805 -- Normal character with no special treatment