1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 -- Warning! Error messages can be generated during Gigi processing by direct
28 -- calls to error message routines, so it is essential that the processing
29 -- in this body be consistent with the requirements for the Gigi processing
30 -- environment, and that in particular, no disallowed table expansion is
33 with Casing; use Casing;
34 with Debug; use Debug;
35 with Err_Vars; use Err_Vars;
36 with Namet; use Namet;
38 with Output; use Output;
39 with Sinput; use Sinput;
40 with Snames; use Snames;
41 with Targparm; use Targparm;
43 with Types; use Types;
44 with Uintp; use Uintp;
46 package body Erroutc is
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
56 procedure Add_Class is
61 Get_Name_String (Name_Class);
62 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
67 ----------------------
68 -- Buffer_Ends_With --
69 ----------------------
71 function Buffer_Ends_With (S : String) return Boolean is
72 Len : constant Natural := S'Length;
76 and then Msg_Buffer (Msglen - Len) = ' '
77 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
84 procedure Buffer_Remove (S : String) is
86 if Buffer_Ends_With (S) then
87 Msglen := Msglen - S'Length;
91 -----------------------------
92 -- Check_Duplicate_Message --
93 -----------------------------
95 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
96 L1, L2 : Error_Msg_Id;
97 N1, N2 : Error_Msg_Id;
99 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
100 -- Called to delete message Delete, keeping message Keep. Marks
101 -- all messages of Delete with deleted flag set to True, and also
102 -- makes sure that for the error messages that are retained the
103 -- preferred message is the one retained (we prefer the shorter
104 -- one in the case where one has an Instance tag). Note that we
105 -- always know that Keep has at least as many continuations as
106 -- Delete (since we always delete the shorter sequence).
112 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
120 Errors.Table (D).Deleted := True;
122 -- Adjust error message count
124 if Errors.Table (D).Warn or Errors.Table (D).Style then
125 Warnings_Detected := Warnings_Detected - 1;
127 Total_Errors_Detected := Total_Errors_Detected - 1;
129 if Errors.Table (D).Serious then
130 Serious_Errors_Detected := Serious_Errors_Detected - 1;
134 -- Substitute shorter of the two error messages
136 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
137 Errors.Table (K).Text := Errors.Table (D).Text;
140 D := Errors.Table (D).Next;
141 K := Errors.Table (K).Next;
143 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
149 -- Start of processing for Check_Duplicate_Message
152 -- Both messages must be non-continuation messages and not deleted
154 if Errors.Table (M1).Msg_Cont
155 or else Errors.Table (M2).Msg_Cont
156 or else Errors.Table (M1).Deleted
157 or else Errors.Table (M2).Deleted
162 -- Definitely not equal if message text does not match
164 if not Same_Error (M1, M2) then
168 -- Same text. See if all continuations are also identical
174 N1 := Errors.Table (L1).Next;
175 N2 := Errors.Table (L2).Next;
177 -- If M1 continuations have run out, we delete M1, either the
178 -- messages have the same number of continuations, or M2 has
179 -- more and we prefer the one with more anyway.
181 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
185 -- If M2 continuatins have run out, we delete M2
187 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
191 -- Otherwise see if continuations are the same, if not, keep both
192 -- sequences, a curious case, but better to keep everything!
194 elsif not Same_Error (N1, N2) then
197 -- If continuations are the same, continue scan
204 end Check_Duplicate_Message;
206 ------------------------
207 -- Compilation_Errors --
208 ------------------------
210 function Compilation_Errors return Boolean is
212 return Total_Errors_Detected /= 0
213 or else (Warnings_Detected /= 0
214 and then Warning_Mode = Treat_As_Error);
215 end Compilation_Errors;
221 procedure Debug_Output (N : Node_Id) is
224 Write_Str ("*** following error message posted on node id = #");
235 procedure dmsg (Id : Error_Msg_Id) is
236 E : Error_Msg_Object renames Errors.Table (Id);
239 w ("Dumping error message, Id = ", Int (Id));
240 w (" Text = ", E.Text.all);
241 w (" Next = ", Int (E.Next));
242 w (" Sfile = ", Int (E.Sfile));
246 Write_Location (E.Sptr);
251 Write_Location (E.Optr);
254 w (" Line = ", Int (E.Line));
255 w (" Col = ", Int (E.Col));
256 w (" Warn = ", E.Warn);
257 w (" Style = ", E.Style);
258 w (" Serious = ", E.Serious);
259 w (" Uncond = ", E.Uncond);
260 w (" Msg_Cont = ", E.Msg_Cont);
261 w (" Deleted = ", E.Deleted);
270 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
272 return Errors.Table (E).Sptr;
279 function Get_Msg_Id return Error_Msg_Id is
284 -----------------------
285 -- Output_Error_Msgs --
286 -----------------------
288 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
294 Mult_Flags : Boolean := False;
299 -- Skip deleted messages at start
301 if Errors.Table (S).Deleted then
302 Set_Next_Non_Deleted_Msg (S);
305 -- Figure out if we will place more than one error flag on this line
308 while T /= No_Error_Msg
309 and then Errors.Table (T).Line = Errors.Table (E).Line
310 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
312 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
316 Set_Next_Non_Deleted_Msg (T);
319 -- Output the error flags. The circuit here makes sure that the tab
320 -- characters in the original line are properly accounted for. The
321 -- eight blanks at the start are to match the line number.
323 if not Debug_Flag_2 then
325 P := Line_Start (Errors.Table (E).Sptr);
328 -- Loop through error messages for this line to place flags
331 while T /= No_Error_Msg
332 and then Errors.Table (T).Line = Errors.Table (E).Line
333 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
335 -- Loop to output blanks till current flag position
337 while P < Errors.Table (T).Sptr loop
338 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
339 Write_Char (ASCII.HT);
347 -- Output flag (unless already output, this happens if more
348 -- than one error message occurs at the same flag position).
350 if P = Errors.Table (T).Sptr then
351 if (Flag_Num = 1 and then not Mult_Flags)
356 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
362 Set_Next_Non_Deleted_Msg (T);
363 Flag_Num := Flag_Num + 1;
369 -- Now output the error messages
372 while T /= No_Error_Msg
373 and then Errors.Table (T).Line = Errors.Table (E).Line
374 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
381 while Column < 74 loop
389 Set_Next_Non_Deleted_Msg (T);
393 end Output_Error_Msgs;
395 ------------------------
396 -- Output_Line_Number --
397 ------------------------
399 procedure Output_Line_Number (L : Logical_Line_Number) is
400 D : Int; -- next digit
401 C : Character; -- next character
402 Z : Boolean; -- flag for zero suppress
403 N, M : Int; -- temporaries
406 if L = No_Line_Number then
427 C := Character'Val (D + 48);
435 end Output_Line_Number;
437 ---------------------
438 -- Output_Msg_Text --
439 ---------------------
441 procedure Output_Msg_Text (E : Error_Msg_Id) is
443 if Errors.Table (E).Warn then
444 Write_Str ("warning: ");
446 elsif Errors.Table (E).Style then
449 elsif Opt.Unique_Error_Tag then
450 Write_Str ("error: ");
453 Write_Str (Errors.Table (E).Text.all);
460 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
463 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
464 -- Returns True for a message that is to be purged. Also adjusts
465 -- error counts appropriately.
471 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
474 and then Errors.Table (E).Sptr > From
475 and then Errors.Table (E).Sptr < To
477 if Errors.Table (E).Warn or Errors.Table (E).Style then
478 Warnings_Detected := Warnings_Detected - 1;
480 Total_Errors_Detected := Total_Errors_Detected - 1;
482 if Errors.Table (E).Serious then
483 Serious_Errors_Detected := Serious_Errors_Detected - 1;
494 -- Start of processing for Purge_Messages
497 while To_Be_Purged (First_Error_Msg) loop
498 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
501 E := First_Error_Msg;
502 while E /= No_Error_Msg loop
503 while To_Be_Purged (Errors.Table (E).Next) loop
504 Errors.Table (E).Next :=
505 Errors.Table (Errors.Table (E).Next).Next;
508 E := Errors.Table (E).Next;
516 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
517 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
518 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
520 Msg2_Len : constant Integer := Msg2'Length;
521 Msg1_Len : constant Integer := Msg1'Length;
527 (Msg1_Len - 10 > Msg2_Len
529 Msg2.all = Msg1.all (1 .. Msg2_Len)
531 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
533 (Msg2_Len - 10 > Msg1_Len
535 Msg1.all = Msg2.all (1 .. Msg1_Len)
537 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
544 procedure Set_Msg_Blank is
547 and then Msg_Buffer (Msglen) /= ' '
548 and then Msg_Buffer (Msglen) /= '('
549 and then not Manual_Quote_Mode
555 -------------------------------
556 -- Set_Msg_Blank_Conditional --
557 -------------------------------
559 procedure Set_Msg_Blank_Conditional is
562 and then Msg_Buffer (Msglen) /= ' '
563 and then Msg_Buffer (Msglen) /= '('
564 and then Msg_Buffer (Msglen) /= '"'
565 and then not Manual_Quote_Mode
569 end Set_Msg_Blank_Conditional;
575 procedure Set_Msg_Char (C : Character) is
578 -- The check for message buffer overflow is needed to deal with cases
579 -- where insertions get too long (in particular a child unit name can
582 if Msglen < Max_Msg_Length then
583 Msglen := Msglen + 1;
584 Msg_Buffer (Msglen) := C;
588 ---------------------------------
589 -- Set_Msg_Insertion_File_Name --
590 ---------------------------------
592 procedure Set_Msg_Insertion_File_Name is
594 if Error_Msg_Name_1 = No_Name then
597 elsif Error_Msg_Name_1 = Error_Name then
599 Set_Msg_Str ("<error>");
603 Get_Name_String (Error_Msg_Name_1);
609 -- The following assignments ensure that the second and third percent
610 -- insertion characters will correspond to the Error_Msg_Name_2 and
611 -- Error_Msg_Name_3 as required.
613 Error_Msg_Name_1 := Error_Msg_Name_2;
614 Error_Msg_Name_2 := Error_Msg_Name_3;
615 end Set_Msg_Insertion_File_Name;
617 -----------------------------------
618 -- Set_Msg_Insertion_Line_Number --
619 -----------------------------------
621 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
622 Sindex_Loc : Source_File_Index;
623 Sindex_Flag : Source_File_Index;
628 if Loc = No_Location then
629 Set_Msg_Str ("at unknown location");
631 elsif Loc = System_Location then
632 Set_Msg_Str ("in package System");
633 Set_Msg_Insertion_Run_Time_Name;
635 elsif Loc = Standard_Location then
636 Set_Msg_Str ("in package Standard");
638 elsif Loc = Standard_ASCII_Location then
639 Set_Msg_Str ("in package Standard.ASCII");
642 -- Add "at file-name:" if reference is to other than the source
643 -- file in which the error message is placed. Note that we check
644 -- full file names, rather than just the source indexes, to
645 -- deal with generic instantiations from the current file.
647 Sindex_Loc := Get_Source_File_Index (Loc);
648 Sindex_Flag := Get_Source_File_Index (Flag);
650 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
653 (Reference_Name (Get_Source_File_Index (Loc)));
657 -- If in current file, add text "at line "
660 Set_Msg_Str ("at line ");
663 -- Output line number for reference
665 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
667 -- Deal with the instantiation case. We may have a reference to,
668 -- e.g. a type, that is declared within a generic template, and
669 -- what we are really referring to is the occurrence in an instance.
670 -- In this case, the line number of the instantiation is also of
671 -- interest, and we add a notation:
675 -- where xxx is a line number output using this same routine (and
676 -- the recursion can go further if the instantiation is itself in
677 -- a generic template).
679 -- The flag location passed to us in this situation is indeed the
680 -- line number within the template, but as described in Sinput.L
681 -- (file sinput-l.ads, section "Handling Generic Instantiations")
682 -- we can retrieve the location of the instantiation itself from
683 -- this flag location value.
685 -- Note: this processing is suppressed if Suppress_Instance_Location
686 -- is set True. This is used to prevent redundant annotations of the
687 -- location of the instantiation in the case where we are placing
688 -- the messages on the instantiation in any case.
690 if Instantiation (Sindex_Loc) /= No_Location
691 and then not Suppress_Instance_Location
693 Set_Msg_Str (", instance ");
694 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
697 end Set_Msg_Insertion_Line_Number;
699 ----------------------------
700 -- Set_Msg_Insertion_Name --
701 ----------------------------
703 procedure Set_Msg_Insertion_Name is
705 if Error_Msg_Name_1 = No_Name then
708 elsif Error_Msg_Name_1 = Error_Name then
710 Set_Msg_Str ("<error>");
713 Set_Msg_Blank_Conditional;
714 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
716 -- Remove %s or %b at end. These come from unit names. If the
717 -- caller wanted the (unit) or (body), then they would have used
718 -- the $ insertion character. Certainly no error message should
719 -- ever have %b or %s explicitly occurring.
722 and then Name_Buffer (Name_Len - 1) = '%'
723 and then (Name_Buffer (Name_Len) = 'b'
725 Name_Buffer (Name_Len) = 's')
727 Name_Len := Name_Len - 2;
730 -- Remove upper case letter at end, again, we should not be getting
731 -- such names, and what we hope is that the remainder makes sense.
734 and then Name_Buffer (Name_Len) in 'A' .. 'Z'
736 Name_Len := Name_Len - 1;
739 -- If operator name or character literal name, just print it as is
740 -- Also print as is if it ends in a right paren (case of x'val(nnn))
742 if Name_Buffer (1) = '"'
743 or else Name_Buffer (1) = '''
744 or else Name_Buffer (Name_Len) = ')'
748 -- Else output with surrounding quotes in proper casing mode
751 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
758 -- The following assignments ensure that the second and third percent
759 -- insertion characters will correspond to the Error_Msg_Name_2 and
760 -- Error_Msg_Name_3 as required.
762 Error_Msg_Name_1 := Error_Msg_Name_2;
763 Error_Msg_Name_2 := Error_Msg_Name_3;
764 end Set_Msg_Insertion_Name;
766 -------------------------------------
767 -- Set_Msg_Insertion_Reserved_Name --
768 -------------------------------------
770 procedure Set_Msg_Insertion_Reserved_Name is
772 Set_Msg_Blank_Conditional;
773 Get_Name_String (Error_Msg_Name_1);
775 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
778 end Set_Msg_Insertion_Reserved_Name;
780 -------------------------------------
781 -- Set_Msg_Insertion_Reserved_Word --
782 -------------------------------------
784 procedure Set_Msg_Insertion_Reserved_Word
789 Set_Msg_Blank_Conditional;
792 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
793 Name_Len := Name_Len + 1;
794 Name_Buffer (Name_Len) := Text (J);
798 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
802 end Set_Msg_Insertion_Reserved_Word;
804 -------------------------------------
805 -- Set_Msg_Insertion_Run_Time_Name --
806 -------------------------------------
808 procedure Set_Msg_Insertion_Run_Time_Name is
810 if Targparm.Run_Time_Name_On_Target /= No_Name then
811 Set_Msg_Blank_Conditional;
813 Get_Name_String (Targparm.Run_Time_Name_On_Target);
814 Set_Casing (Mixed_Case);
815 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
818 end Set_Msg_Insertion_Run_Time_Name;
820 ----------------------------
821 -- Set_Msg_Insertion_Uint --
822 ----------------------------
824 procedure Set_Msg_Insertion_Uint is
827 UI_Image (Error_Msg_Uint_1);
829 for J in 1 .. UI_Image_Length loop
830 Set_Msg_Char (UI_Image_Buffer (J));
833 -- The following assignment ensures that a second carret insertion
834 -- character will correspond to the Error_Msg_Uint_2 parameter.
836 Error_Msg_Uint_1 := Error_Msg_Uint_2;
837 end Set_Msg_Insertion_Uint;
843 procedure Set_Msg_Int (Line : Int) is
846 Set_Msg_Int (Line / 10);
849 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
852 -------------------------
853 -- Set_Msg_Name_Buffer --
854 -------------------------
856 procedure Set_Msg_Name_Buffer is
858 for J in 1 .. Name_Len loop
859 Set_Msg_Char (Name_Buffer (J));
861 end Set_Msg_Name_Buffer;
867 procedure Set_Msg_Quote is
869 if not Manual_Quote_Mode then
878 procedure Set_Msg_Str (Text : String) is
880 for J in Text'Range loop
881 Set_Msg_Char (Text (J));
885 ------------------------------
886 -- Set_Next_Non_Deleted_Msg --
887 ------------------------------
889 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
891 if E = No_Error_Msg then
896 E := Errors.Table (E).Next;
897 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
900 end Set_Next_Non_Deleted_Msg;
902 ---------------------------
903 -- Set_Warnings_Mode_Off --
904 ---------------------------
906 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
908 -- Don't bother with entries from instantiation copies, since we
909 -- will already have a copy in the template, which is what matters
911 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
915 -- If last entry in table already covers us, this is a redundant
916 -- pragma Warnings (Off) and can be ignored. This also handles the
917 -- case where all warnings are suppressed by command line switch.
919 if Warnings.Last >= Warnings.First
920 and then Warnings.Table (Warnings.Last).Start <= Loc
921 and then Loc <= Warnings.Table (Warnings.Last).Stop
925 -- Otherwise establish a new entry, extending from the location of
926 -- the pragma to the end of the current source file. This ending
927 -- point will be adjusted by a subsequent pragma Warnings (On).
930 Warnings.Increment_Last;
931 Warnings.Table (Warnings.Last).Start := Loc;
932 Warnings.Table (Warnings.Last).Stop :=
933 Source_Last (Current_Source_File);
935 end Set_Warnings_Mode_Off;
937 --------------------------
938 -- Set_Warnings_Mode_On --
939 --------------------------
941 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
943 -- Don't bother with entries from instantiation copies, since we
944 -- will already have a copy in the template, which is what matters
946 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
950 -- Nothing to do unless command line switch to suppress all warnings
951 -- is off, and the last entry in the warnings table covers this
952 -- pragma Warnings (On), in which case adjust the end point.
954 if (Warnings.Last >= Warnings.First
955 and then Warnings.Table (Warnings.Last).Start <= Loc
956 and then Loc <= Warnings.Table (Warnings.Last).Stop)
957 and then Warning_Mode /= Suppress
959 Warnings.Table (Warnings.Last).Stop := Loc;
961 end Set_Warnings_Mode_On;
963 ------------------------------------
964 -- Test_Style_Warning_Serious_Msg --
965 ------------------------------------
967 procedure Test_Style_Warning_Serious_Msg (Msg : String) is
969 if Msg (Msg'First) = '\' then
973 Is_Serious_Error := True;
974 Is_Warning_Msg := False;
978 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
980 for J in Msg'Range loop
982 and then (J = Msg'First or else Msg (J - 1) /= ''')
984 Is_Warning_Msg := True;
987 and then (J = Msg'First or else Msg (J - 1) /= ''')
989 Is_Serious_Error := False;
993 if Is_Warning_Msg or else Is_Style_Msg then
994 Is_Serious_Error := False;
996 end Test_Style_Warning_Serious_Msg;
998 -------------------------
999 -- Warnings_Suppressed --
1000 -------------------------
1002 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1004 for J in Warnings.First .. Warnings.Last loop
1005 if Warnings.Table (J).Start <= Loc
1006 and then Loc <= Warnings.Table (J).Stop
1013 end Warnings_Suppressed;