1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1991-2024, 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 -- Warning, Style and Info attributes are mutually exclusive
204 pragma Assert
(Boolean'Pos (Is_Warning_Msg
) + Boolean'Pos (Is_Info_Msg
) +
205 Boolean'Pos (Is_Style_Msg
) <= 1);
207 -- Otherwise build error message object for new message
211 (Text
=> new String'(Msg_Buffer (1 .. Msglen)),
212 Next => No_Error_Msg,
213 Prev => No_Error_Msg,
214 Sfile => Get_Source_File_Index (Sptr),
215 Sptr => To_Span (Sptr),
216 Optr => To_Span (Optr),
217 Insertion_Sloc => No_Location,
218 Line => Get_Physical_Line_Number (Sptr),
219 Col => Get_Column_Number (Sptr),
220 Compile_Time_Pragma => Is_Compile_Time_Msg,
221 Warn => Is_Warning_Msg,
223 Check => Is_Check_Msg,
224 Warn_Err => Warning_Mode = Treat_As_Error,
225 Warn_Runtime_Raise => Is_Runtime_Raise,
226 Warn_Chr => Warning_Msg_Char,
227 Style => Is_Style_Msg,
228 Serious => Is_Serious_Error,
229 Uncond => Is_Unconditional_Msg,
230 Msg_Cont => Continuation,
233 Cur_Msg := Errors.Last;
234 Prev_Msg := No_Error_Msg;
235 Next_Msg := First_Error_Msg;
237 while Next_Msg /= No_Error_Msg loop
239 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
241 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then
242 exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr;
245 Prev_Msg := Next_Msg;
246 Next_Msg := Errors.Table (Next_Msg).Next;
249 -- Now we insert the new message in the error chain. The insertion
250 -- point for the message is after Prev_Msg and before Next_Msg.
252 -- The possible insertion point for the new message is after Prev_Msg
253 -- and before Next_Msg. However, this is where we do a special check
254 -- for redundant parsing messages, defined as messages posted on the
255 -- same line. The idea here is that probably such messages are junk
256 -- from the parser recovering. In full errors mode, we don't do this
257 -- deletion, but otherwise such messages are discarded at this stage.
259 if Prev_Msg /= No_Error_Msg
260 and then Errors.Table (Prev_Msg).Line =
261 Errors.Table (Cur_Msg).Line
262 and then Errors.Table (Prev_Msg).Sfile =
263 Errors.Table (Cur_Msg).Sfile
265 -- Don't delete unconditional messages and at this stage, don't
266 -- delete continuation lines (we attempted to delete those earlier
267 -- if the parent message was deleted.
269 if not Errors.Table (Cur_Msg).Uncond
270 and then not Continuation
273 -- Don't delete if prev msg is warning and new msg is an error.
274 -- This is because we don't want a real error masked by a warning.
275 -- In all other cases (that is parse errors for the same line that
276 -- are not unconditional) we do delete the message. This helps to
277 -- avoid junk extra messages from cascaded parsing errors
279 if not (Errors.Table (Prev_Msg).Warn
281 Errors.Table (Prev_Msg).Style)
283 (Errors.Table (Cur_Msg).Warn
285 Errors.Table (Cur_Msg).Style)
287 -- All tests passed, delete the message by simply returning
288 -- without any further processing.
290 if not Continuation then
299 -- Come here if message is to be inserted in the error chain
301 if not Continuation then
302 Last_Killed := False;
305 if Prev_Msg = No_Error_Msg then
306 First_Error_Msg := Cur_Msg;
308 Errors.Table (Prev_Msg).Next := Cur_Msg;
311 Errors.Table (Cur_Msg).Next := Next_Msg;
313 -- Bump appropriate statistics counts
315 if Errors.Table (Cur_Msg).Info then
316 Info_Messages := Info_Messages + 1;
318 elsif Errors.Table (Cur_Msg).Warn
319 or else Errors.Table (Cur_Msg).Style
321 Warnings_Detected := Warnings_Detected + 1;
323 elsif Errors.Table (Cur_Msg).Check then
324 Check_Messages := Check_Messages + 1;
327 Total_Errors_Detected := Total_Errors_Detected + 1;
329 if Errors.Table (Cur_Msg).Serious then
330 Serious_Errors_Detected := Serious_Errors_Detected + 1;
340 procedure Error_Msg_S (Msg : String) is
342 Error_Msg (Msg, Scan_Ptr);
349 procedure Error_Msg_SC (Msg : String) is
351 -- If we are at end of file, post the flag after the previous token
353 if Token = Tok_EOF then
356 -- For all other cases the message is posted at the current token
360 Error_Msg (Msg, Token_Ptr);
368 procedure Error_Msg_SP (Msg : String) is
370 -- Note: in the case where there is no previous token, Prev_Token_Ptr
371 -- is set to Source_First, which is a reasonable position for the
372 -- error flag in this situation
374 Error_Msg (Msg, Prev_Token_Ptr);
381 procedure Finalize (Source_Type : String := "project") is
388 -- Eliminate any duplicated error messages from the list. This is
389 -- done after the fact to avoid problems with Change_Error_Text.
391 Cur := First_Error_Msg;
392 while Cur /= No_Error_Msg loop
393 Nxt := Errors.Table (Cur).Next;
396 while F /= No_Error_Msg
397 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
399 Check_Duplicate_Message (Cur, F);
400 F := Errors.Table (F).Next;
408 if Brief_Output or (not Full_List and not Verbose_Mode) then
409 E := First_Error_Msg;
412 while E /= No_Error_Msg loop
413 if not Errors.Table (E).Deleted then
414 if Full_Path_Name_For_Brief_Errors then
415 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
417 Write_Name (Reference_Name (Errors.Table (E).Sfile));
421 Write_Int (Int (Physical_To_Logical
422 (Errors.Table (E).Line,
423 Errors.Table (E).Sfile)));
426 if Errors.Table (E).Col < 10 then
430 Write_Int (Int (Errors.Table (E).Col));
436 E := Errors.Table (E).Next;
442 -- Full source listing case
445 List_Pragmas_Index := 1;
446 List_Pragmas_Mode := True;
447 E := First_Error_Msg;
450 -- First list initial main source file with its error messages
452 for N in 1 .. Last_Source_Line (Main_Source_File) loop
455 and then Errors.Table (E).Line = N
456 and then Errors.Table (E).Sfile = Main_Source_File;
458 Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type);
461 Output_Error_Msgs (E);
467 -- Then output errors, if any, for subsidiary units
469 while E /= No_Error_Msg
470 and then Errors.Table (E).Sfile /= Main_Source_File
474 (Errors.Table (E).Line,
475 Errors.Table (E).Sfile,
478 Output_Error_Msgs (E);
482 -- Verbose mode (error lines only with error flags)
485 E := First_Error_Msg;
487 -- Loop through error lines
489 while E /= No_Error_Msg loop
492 (Errors.Table (E).Line,
493 Errors.Table (E).Sfile,
496 Output_Error_Msgs (E);
500 -- Output error summary if verbose or full list mode
502 if Verbose_Mode or else Full_List then
504 -- Extra blank line if error messages or source listing were output
506 if Total_Errors_Detected + Warnings_Detected > 0
512 -- Message giving number of lines read and number of errors detected.
513 -- This normally goes to Standard_Output. The exception is when brief
514 -- mode is not set, verbose mode (or full list mode) is set, and
515 -- there are errors. In this case we send the message to standard
516 -- error to make sure that *something* appears on standard error in
517 -- an error situation.
519 -- Historical note: Formerly, only the "# errors" suffix was sent
520 -- to stderr, whereas "# lines:" appeared on stdout. This caused
521 -- some problems on now-obsolete ports, but there seems to be no
522 -- reason to revert this page since it would be incompatible.
524 if Total_Errors_Detected + Warnings_Detected /= 0
525 and then not Brief_Output
526 and then (Verbose_Mode or Full_List)
531 -- Message giving total number of lines
534 Write_Int (Num_Source_Lines (Main_Source_File));
536 if Num_Source_Lines (Main_Source_File) = 1 then
537 Write_Str (" line: ");
539 Write_Str (" lines: ");
542 if Total_Errors_Detected = 0 then
543 Write_Str ("No errors");
545 elsif Total_Errors_Detected = 1 then
546 Write_Str ("1 error");
549 Write_Int (Total_Errors_Detected);
550 Write_Str (" errors");
553 if Warnings_Detected /= 0 then
555 Write_Int (Warnings_Detected);
556 Write_Str (" warning");
558 if Warnings_Detected /= 1 then
562 if Warning_Mode = Treat_As_Error then
563 Write_Str (" (treated as error");
565 if Warnings_Detected /= 1 then
577 if Maximum_Messages /= 0 then
578 if Warnings_Detected >= Maximum_Messages then
580 Write_Line ("maximum number of warnings detected");
581 Warning_Mode := Suppress;
584 if Total_Errors_Detected >= Maximum_Messages then
586 Write_Line ("fatal error: maximum errors reached");
591 -- Even though Warning_Info_Messages are a subclass of warnings, they
592 -- must not be treated as errors when -gnatwe is in effect.
594 if Warning_Mode = Treat_As_Error then
595 Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
596 Warnings_Detected := 0;
599 -- Prevent displaying the same messages again in the future
601 First_Error_Msg := No_Error_Msg;
608 procedure Initialize is
611 First_Error_Msg := No_Error_Msg;
612 Last_Error_Msg := No_Error_Msg;
613 Serious_Errors_Detected := 0;
614 Total_Errors_Detected := 0;
615 Warnings_Detected := 0;
617 Cur_Msg := No_Error_Msg;
619 -- Initialize warnings table, if all warnings are suppressed, supply
620 -- an initial dummy entry covering all possible source locations.
624 if Warning_Mode = Suppress then
627 (Start => Source_Ptr'First,
628 Stop => Source_Ptr'Last,
629 Reason => Null_String_Id));
633 ------------------------
634 -- Output_Source_Line --
635 ------------------------
637 procedure Output_Source_Line
638 (L : Physical_Line_Number;
639 Sfile : Source_File_Index;
641 Source_Type : String)
646 Line_Number_Output : Boolean := False;
647 -- Set True once line number is output
650 if Sfile /= Current_Error_Source_File then
651 Write_Str ("==============Error messages for ");
652 Write_Str (Source_Type);
653 Write_Str (" file: ");
654 Write_Name (Full_File_Name (Sfile));
656 Current_Error_Source_File := Sfile;
660 Output_Line_Number (Physical_To_Logical (L, Sfile));
661 Line_Number_Output := True;
664 S := Line_Start (L, Sfile);
667 C := Source_Text (Sfile) (S);
668 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
677 if Line_Number_Output then
680 end Output_Source_Line;
682 -----------------------
683 -- Set_Ignore_Errors --
684 -----------------------
686 procedure Set_Ignore_Errors (To : Boolean) is
688 Errors_Must_Be_Ignored := To;
689 end Set_Ignore_Errors;
691 ------------------------------
692 -- Set_Msg_Insertion_Column --
693 ------------------------------
695 procedure Set_Msg_Insertion_Column is
697 if RM_Column_Check then
698 Set_Msg_Str (" in column ");
699 Set_Msg_Int (Int (Error_Msg_Col) + 1);
701 end Set_Msg_Insertion_Column;
707 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
708 C : Character; -- Current character
709 P : Natural; -- Current index;
712 Manual_Quote_Mode := False;
714 Flag_Source := Get_Source_File_Index (Flag);
717 while P <= Text'Last loop
721 -- Check for insertion character
724 if P <= Text'Last and then Text (P) = '%' then
726 Set_Msg_Insertion_Name_Literal;
728 Set_Msg_Insertion_Name;
738 Set_Msg_Insertion_File_Name;
747 Set_Msg_Insertion_Reserved_Name;
756 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
759 Continuation := True;
762 Set_Msg_Insertion_Column;
765 Set_Msg_Insertion_Uint;
768 Manual_Quote_Mode := not Manual_Quote_Mode;
784 Set_Msg_Char (Text (P));
787 -- Upper case letter (start of reserved word if 2 or more)
789 elsif C in 'A' .. 'Z'
790 and then P <= Text'Last
791 and then Text (P) in 'A' .. 'Z'
794 Set_Msg_Insertion_Reserved_Word (Text, P);
797 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
799 -- Normal character with no special treatment