hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / errutil.adb
blob8b3c2ec2bfa378bbb5772dac771be56c7342af57
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E R R U T I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1991-2023, 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 Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Err_Vars; use Err_Vars;
28 with Erroutc; use Erroutc;
29 with Namet; use Namet;
30 with Opt; use Opt;
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;
54 Errs : Boolean;
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.
72 ------------------
73 -- Error_Msg_AP --
74 ------------------
76 procedure Error_Msg_AP (Msg : String) is
77 S1 : Source_Ptr;
78 C : Character;
80 begin
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.
98 S1 := Prev_Token_Ptr;
99 C := Source (S1);
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
110 loop
111 S1 := S1 + 1;
113 if Source (S1) = C then
114 S1 := S1 + 1;
115 exit when Source (S1) /= C;
116 elsif Source (S1) in Line_Terminator then
117 exit;
118 end if;
119 end loop;
121 -- Character literal also needs special handling
123 elsif Prev_Token = Tok_Char_Literal then
124 S1 := S1 + 3;
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.
134 else
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
140 loop
141 S1 := S1 + 1;
142 end loop;
143 end if;
145 -- S1 is now set to the location for the flag
147 Error_Msg (Msg, S1);
149 end Error_Msg_AP;
151 ---------------
152 -- Error_Msg --
153 ---------------
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.
171 begin
172 if Errors_Must_Be_Ignored then
173 return;
174 end if;
176 if Raise_Exception_On_Error /= 0 then
177 raise Error_Msg_Exception;
178 end if;
180 Prescan_Message (Msg);
181 Set_Msg_Text (Msg, Sptr);
183 -- Kill continuation if parent message killed
185 if Continuation and Last_Killed then
186 return;
187 end if;
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;
199 return;
200 end if;
202 -- Otherwise build error message object for new message
204 Errors.Append
205 (New_Val =>
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,
217 Info => Is_Info_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,
226 Deleted => False,
227 Node => Empty));
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
234 exit when
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;
239 end if;
241 Prev_Msg := Next_Msg;
242 Next_Msg := Errors.Table (Next_Msg).Next;
243 end loop;
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
260 then
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
267 then
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
276 or else
277 Errors.Table (Prev_Msg).Style)
278 or else
279 (Errors.Table (Cur_Msg).Warn
280 or else
281 Errors.Table (Cur_Msg).Style)
282 then
283 -- All tests passed, delete the message by simply returning
284 -- without any further processing.
286 if not Continuation then
287 Last_Killed := True;
288 end if;
290 return;
291 end if;
292 end if;
293 end if;
295 -- Come here if message is to be inserted in the error chain
297 if not Continuation then
298 Last_Killed := False;
299 end if;
301 if Prev_Msg = No_Error_Msg then
302 First_Error_Msg := Cur_Msg;
303 else
304 Errors.Table (Prev_Msg).Next := Cur_Msg;
305 end if;
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;
318 else
319 Report_Info_Messages := Report_Info_Messages + 1;
320 end if;
322 elsif Errors.Table (Cur_Msg).Warn
323 or else Errors.Table (Cur_Msg).Style
324 then
325 Warnings_Detected := Warnings_Detected + 1;
327 elsif Errors.Table (Cur_Msg).Check then
328 Check_Messages := Check_Messages + 1;
330 else
331 Total_Errors_Detected := Total_Errors_Detected + 1;
333 if Errors.Table (Cur_Msg).Serious then
334 Serious_Errors_Detected := Serious_Errors_Detected + 1;
335 end if;
336 end if;
338 end Error_Msg;
340 -----------------
341 -- Error_Msg_S --
342 -----------------
344 procedure Error_Msg_S (Msg : String) is
345 begin
346 Error_Msg (Msg, Scan_Ptr);
347 end Error_Msg_S;
349 ------------------
350 -- Error_Msg_SC --
351 ------------------
353 procedure Error_Msg_SC (Msg : String) is
354 begin
355 -- If we are at end of file, post the flag after the previous token
357 if Token = Tok_EOF then
358 Error_Msg_AP (Msg);
360 -- For all other cases the message is posted at the current token
361 -- pointer position
363 else
364 Error_Msg (Msg, Token_Ptr);
365 end if;
366 end Error_Msg_SC;
368 ------------------
369 -- Error_Msg_SP --
370 ------------------
372 procedure Error_Msg_SP (Msg : String) is
373 begin
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);
379 end Error_Msg_SP;
381 --------------
382 -- Finalize --
383 --------------
385 procedure Finalize (Source_Type : String := "project") is
386 Cur : Error_Msg_Id;
387 Nxt : Error_Msg_Id;
388 E, F : Error_Msg_Id;
389 Err_Flag : Boolean;
391 begin
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;
399 F := Nxt;
400 while F /= No_Error_Msg
401 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
402 loop
403 Check_Duplicate_Message (Cur, F);
404 F := Errors.Table (F).Next;
405 end loop;
407 Cur := Nxt;
408 end loop;
410 -- Brief Error mode
412 if Brief_Output or (not Full_List and not Verbose_Mode) then
413 E := First_Error_Msg;
414 Set_Standard_Error;
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));
420 else
421 Write_Name (Reference_Name (Errors.Table (E).Sfile));
422 end if;
424 Write_Char (':');
425 Write_Int (Int (Physical_To_Logical
426 (Errors.Table (E).Line,
427 Errors.Table (E).Sfile)));
428 Write_Char (':');
430 if Errors.Table (E).Col < 10 then
431 Write_Char ('0');
432 end if;
434 Write_Int (Int (Errors.Table (E).Col));
435 Write_Str (": ");
436 Output_Msg_Text (E);
437 Write_Eol;
438 end if;
440 E := Errors.Table (E).Next;
441 end loop;
443 Set_Standard_Output;
444 end if;
446 -- Full source listing case
448 if Full_List then
449 List_Pragmas_Index := 1;
450 List_Pragmas_Mode := True;
451 E := First_Error_Msg;
452 Write_Eol;
454 -- First list initial main source file with its error messages
456 for N in 1 .. Last_Source_Line (Main_Source_File) loop
457 Err_Flag :=
458 E /= No_Error_Msg
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);
464 if Err_Flag then
465 Output_Error_Msgs (E);
467 Write_Eol;
468 end if;
469 end loop;
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
475 loop
476 Write_Eol;
477 Output_Source_Line
478 (Errors.Table (E).Line,
479 Errors.Table (E).Sfile,
480 True,
481 Source_Type);
482 Output_Error_Msgs (E);
483 end loop;
484 end if;
486 -- Verbose mode (error lines only with error flags)
488 if Verbose_Mode then
489 E := First_Error_Msg;
491 -- Loop through error lines
493 while E /= No_Error_Msg loop
494 Write_Eol;
495 Output_Source_Line
496 (Errors.Table (E).Line,
497 Errors.Table (E).Sfile,
498 True,
499 Source_Type);
500 Output_Error_Msgs (E);
501 end loop;
502 end if;
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
511 or else Full_List
512 then
513 Write_Eol;
514 end if;
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)
531 then
532 Set_Standard_Error;
533 end if;
535 -- Message giving total number of lines
537 Write_Str (" ");
538 Write_Int (Num_Source_Lines (Main_Source_File));
540 if Num_Source_Lines (Main_Source_File) = 1 then
541 Write_Str (" line: ");
542 else
543 Write_Str (" lines: ");
544 end if;
546 if Total_Errors_Detected = 0 then
547 Write_Str ("No errors");
549 elsif Total_Errors_Detected = 1 then
550 Write_Str ("1 error");
552 else
553 Write_Int (Total_Errors_Detected);
554 Write_Str (" errors");
555 end if;
557 if Warnings_Detected - Warning_Info_Messages /= 0 then
558 Write_Str (", ");
559 Write_Int (Warnings_Detected - Warning_Info_Messages);
560 Write_Str (" warning");
562 if Warnings_Detected - Warning_Info_Messages /= 1 then
563 Write_Char ('s');
564 end if;
566 if Warning_Mode = Treat_As_Error then
567 Write_Str (" (treated as error");
569 if Warnings_Detected - Warning_Info_Messages /= 1 then
570 Write_Char ('s');
571 end if;
573 Write_Char (')');
574 end if;
575 end if;
577 Write_Eol;
578 Set_Standard_Output;
579 end if;
581 if Maximum_Messages /= 0 then
582 if Warnings_Detected >= Maximum_Messages then
583 Set_Standard_Error;
584 Write_Line ("maximum number of warnings detected");
585 Warning_Mode := Suppress;
586 end if;
588 if Total_Errors_Detected >= Maximum_Messages then
589 Set_Standard_Error;
590 Write_Line ("fatal error: maximum errors reached");
591 Set_Standard_Output;
592 end if;
593 end if;
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;
602 end if;
604 -- Prevent displaying the same messages again in the future
606 First_Error_Msg := No_Error_Msg;
607 end Finalize;
609 ----------------
610 -- Initialize --
611 ----------------
613 procedure Initialize is
614 begin
615 Errors.Init;
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.
628 Warnings.Init;
630 if Warning_Mode = Suppress then
631 Warnings.Append
632 (New_Val =>
633 (Start => Source_Ptr'First,
634 Stop => Source_Ptr'Last,
635 Reason => Null_String_Id));
636 end if;
637 end Initialize;
639 ------------------------
640 -- Output_Source_Line --
641 ------------------------
643 procedure Output_Source_Line
644 (L : Physical_Line_Number;
645 Sfile : Source_File_Index;
646 Errs : Boolean;
647 Source_Type : String)
649 S : Source_Ptr;
650 C : Character;
652 Line_Number_Output : Boolean := False;
653 -- Set True once line number is output
655 begin
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));
661 Write_Eol;
662 Current_Error_Source_File := Sfile;
663 end if;
665 if Errs then
666 Output_Line_Number (Physical_To_Logical (L, Sfile));
667 Line_Number_Output := True;
668 end if;
670 S := Line_Start (L, Sfile);
672 loop
673 C := Source_Text (Sfile) (S);
674 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
676 if Errs then
677 Write_Char (C);
678 end if;
680 S := S + 1;
681 end loop;
683 if Line_Number_Output then
684 Write_Eol;
685 end if;
686 end Output_Source_Line;
688 -----------------------
689 -- Set_Ignore_Errors --
690 -----------------------
692 procedure Set_Ignore_Errors (To : Boolean) is
693 begin
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
702 begin
703 if RM_Column_Check then
704 Set_Msg_Str (" in column ");
705 Set_Msg_Int (Int (Error_Msg_Col) + 1);
706 end if;
707 end Set_Msg_Insertion_Column;
709 ------------------
710 -- Set_Msg_Text --
711 ------------------
713 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
714 C : Character; -- Current character
715 P : Natural; -- Current index;
717 begin
718 Manual_Quote_Mode := False;
719 Msglen := 0;
720 Flag_Source := Get_Source_File_Index (Flag);
721 P := Text'First;
723 while P <= Text'Last loop
724 C := Text (P);
725 P := P + 1;
727 -- Check for insertion character
729 if C = '%' then
730 if P <= Text'Last and then Text (P) = '%' then
731 P := P + 1;
732 Set_Msg_Insertion_Name_Literal;
733 else
734 Set_Msg_Insertion_Name;
735 end if;
737 elsif C = '$' then
739 -- '$' is ignored
741 null;
743 elsif C = '{' then
744 Set_Msg_Insertion_File_Name;
746 elsif C = '}' then
748 -- '}' is ignored
750 null;
752 elsif C = '*' then
753 Set_Msg_Insertion_Reserved_Name;
755 elsif C = '&' then
757 -- '&' is ignored
759 null;
761 elsif C = '#' then
762 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
764 elsif C = '\' then
765 Continuation := True;
767 elsif C = '@' then
768 Set_Msg_Insertion_Column;
770 elsif C = '^' then
771 Set_Msg_Insertion_Uint;
773 elsif C = '`' then
774 Manual_Quote_Mode := not Manual_Quote_Mode;
775 Set_Msg_Char ('"');
777 elsif C = '!' then
778 null;
780 elsif C = '?' then
781 null;
783 elsif C = '<' then
784 null;
786 elsif C = '|' then
787 null;
789 elsif C = ''' then
790 Set_Msg_Char (Text (P));
791 P := P + 1;
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'
798 then
799 P := P - 1;
800 Set_Msg_Insertion_Reserved_Word (Text, P);
802 elsif C = '~' then
803 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
805 -- Normal character with no special treatment
807 else
808 Set_Msg_Char (C);
809 end if;
811 end loop;
812 end Set_Msg_Text;
814 end Errutil;