1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
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
;
42 with Uintp
; use Uintp
;
44 package body Erroutc
is
50 procedure Add_Class
is
55 Get_Name_String
(Name_Class
);
56 Set_Casing
(Identifier_Casing
(Flag_Source
), Mixed_Case
);
61 ----------------------
62 -- Buffer_Ends_With --
63 ----------------------
65 function Buffer_Ends_With
(S
: String) return Boolean is
66 Len
: constant Natural := S
'Length;
70 and then Msg_Buffer
(Msglen
- Len
) = ' '
71 and then Msg_Buffer
(Msglen
- Len
+ 1 .. Msglen
) = S
;
78 procedure Buffer_Remove
(S
: String) is
80 if Buffer_Ends_With
(S
) then
81 Msglen
:= Msglen
- S
'Length;
85 -----------------------------
86 -- Check_Duplicate_Message --
87 -----------------------------
89 procedure Check_Duplicate_Message
(M1
, M2
: Error_Msg_Id
) is
90 L1
, L2
: Error_Msg_Id
;
91 N1
, N2
: Error_Msg_Id
;
93 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
);
94 -- Called to delete message Delete, keeping message Keep. Marks
95 -- all messages of Delete with deleted flag set to True, and also
96 -- makes sure that for the error messages that are retained the
97 -- preferred message is the one retained (we prefer the shorter
98 -- one in the case where one has an Instance tag). Note that we
99 -- always know that Keep has at least as many continuations as
100 -- Delete (since we always delete the shorter sequence).
106 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
) is
114 Errors
.Table
(D
).Deleted
:= True;
116 -- Adjust error message count
118 if Errors
.Table
(D
).Warn
or else Errors
.Table
(D
).Style
then
119 Warnings_Detected
:= Warnings_Detected
- 1;
122 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
124 if Errors
.Table
(D
).Serious
then
125 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
129 -- Substitute shorter of the two error messages
131 if Errors
.Table
(K
).Text
'Length > Errors
.Table
(D
).Text
'Length then
132 Errors
.Table
(K
).Text
:= Errors
.Table
(D
).Text
;
135 D
:= Errors
.Table
(D
).Next
;
136 K
:= Errors
.Table
(K
).Next
;
138 if D
= No_Error_Msg
or else not Errors
.Table
(D
).Msg_Cont
then
144 -- Start of processing for Check_Duplicate_Message
147 -- Both messages must be non-continuation messages and not deleted
149 if Errors
.Table
(M1
).Msg_Cont
150 or else Errors
.Table
(M2
).Msg_Cont
151 or else Errors
.Table
(M1
).Deleted
152 or else Errors
.Table
(M2
).Deleted
157 -- Definitely not equal if message text does not match
159 if not Same_Error
(M1
, M2
) then
163 -- Same text. See if all continuations are also identical
169 N1
:= Errors
.Table
(L1
).Next
;
170 N2
:= Errors
.Table
(L2
).Next
;
172 -- If M1 continuations have run out, we delete M1, either the
173 -- messages have the same number of continuations, or M2 has
174 -- more and we prefer the one with more anyway.
176 if N1
= No_Error_Msg
or else not Errors
.Table
(N1
).Msg_Cont
then
180 -- If M2 continuations have run out, we delete M2
182 elsif N2
= No_Error_Msg
or else not Errors
.Table
(N2
).Msg_Cont
then
186 -- Otherwise see if continuations are the same, if not, keep both
187 -- sequences, a curious case, but better to keep everything!
189 elsif not Same_Error
(N1
, N2
) then
192 -- If continuations are the same, continue scan
199 end Check_Duplicate_Message
;
201 ------------------------
202 -- Compilation_Errors --
203 ------------------------
205 function Compilation_Errors
return Boolean is
207 return Total_Errors_Detected
/= 0
208 or else (Warnings_Detected
/= 0
209 and then Warning_Mode
= Treat_As_Error
);
210 end Compilation_Errors
;
216 procedure Debug_Output
(N
: Node_Id
) is
219 Write_Str
("*** following error message posted on node id = #");
230 procedure dmsg
(Id
: Error_Msg_Id
) is
231 E
: Error_Msg_Object
renames Errors
.Table
(Id
);
234 w
("Dumping error message, Id = ", Int
(Id
));
235 w
(" Text = ", E
.Text
.all);
236 w
(" Next = ", Int
(E
.Next
));
237 w
(" Sfile = ", Int
(E
.Sfile
));
241 Write_Location
(E
.Sptr
);
246 Write_Location
(E
.Optr
);
249 w
(" Line = ", Int
(E
.Line
));
250 w
(" Col = ", Int
(E
.Col
));
251 w
(" Warn = ", E
.Warn
);
252 w
(" Style = ", E
.Style
);
253 w
(" Serious = ", E
.Serious
);
254 w
(" Uncond = ", E
.Uncond
);
255 w
(" Msg_Cont = ", E
.Msg_Cont
);
256 w
(" Deleted = ", E
.Deleted
);
265 function Get_Location
(E
: Error_Msg_Id
) return Source_Ptr
is
267 return Errors
.Table
(E
).Sptr
;
274 function Get_Msg_Id
return Error_Msg_Id
is
279 -----------------------
280 -- Output_Error_Msgs --
281 -----------------------
283 procedure Output_Error_Msgs
(E
: in out Error_Msg_Id
) is
289 Mult_Flags
: Boolean := False;
294 -- Skip deleted messages at start
296 if Errors
.Table
(S
).Deleted
then
297 Set_Next_Non_Deleted_Msg
(S
);
300 -- Figure out if we will place more than one error flag on this line
303 while T
/= No_Error_Msg
304 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
305 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
307 if Errors
.Table
(T
).Sptr
> Errors
.Table
(E
).Sptr
then
311 Set_Next_Non_Deleted_Msg
(T
);
314 -- Output the error flags. The circuit here makes sure that the tab
315 -- characters in the original line are properly accounted for. The
316 -- eight blanks at the start are to match the line number.
318 if not Debug_Flag_2
then
320 P
:= Line_Start
(Errors
.Table
(E
).Sptr
);
323 -- Loop through error messages for this line to place flags
326 while T
/= No_Error_Msg
327 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
328 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
330 -- Loop to output blanks till current flag position
332 while P
< Errors
.Table
(T
).Sptr
loop
333 if Source_Text
(Errors
.Table
(T
).Sfile
) (P
) = ASCII
.HT
then
334 Write_Char
(ASCII
.HT
);
342 -- Output flag (unless already output, this happens if more
343 -- than one error message occurs at the same flag position).
345 if P
= Errors
.Table
(T
).Sptr
then
346 if (Flag_Num
= 1 and then not Mult_Flags
)
351 Write_Char
(Character'Val (Character'Pos ('0') + Flag_Num
));
357 Set_Next_Non_Deleted_Msg
(T
);
358 Flag_Num
:= Flag_Num
+ 1;
364 -- Now output the error messages
367 while T
/= No_Error_Msg
368 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
369 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
375 while Column
< 74 loop
383 Set_Next_Non_Deleted_Msg
(T
);
387 end Output_Error_Msgs
;
389 ------------------------
390 -- Output_Line_Number --
391 ------------------------
393 procedure Output_Line_Number
(L
: Logical_Line_Number
) is
394 D
: Int
; -- next digit
395 C
: Character; -- next character
396 Z
: Boolean; -- flag for zero suppress
397 N
, M
: Int
; -- temporaries
400 if L
= No_Line_Number
then
421 C
:= Character'Val (D
+ 48);
429 end Output_Line_Number
;
431 ---------------------
432 -- Output_Msg_Text --
433 ---------------------
435 procedure Output_Msg_Text
(E
: Error_Msg_Id
) is
436 Offs
: constant Nat
:= Column
- 1;
437 -- Offset to start of message, used for continuations
440 -- Maximum characters to output on next line
443 -- Maximum total length of lines
445 Txt
: constant String_Ptr
:= Errors
.Table
(E
).Text
;
446 Len
: constant Natural := Txt
'Length;
452 if Error_Msg_Line_Length
= 0 then
455 Length
:= Error_Msg_Line_Length
;
458 Max
:= Integer (Length
- Column
+ 1);
460 -- For warning message, add "warning: " unless msg starts with "info: "
462 if Errors
.Table
(E
).Warn
then
463 if Len
< 6 or else Txt
(Txt
'First .. Txt
'First + 5) /= "info: " then
464 Write_Str
("warning: ");
468 -- No prefix needed for style message, since "(style)" is there already
470 elsif Errors
.Table
(E
).Style
then
473 -- All other cases, add "error: "
475 elsif Opt
.Unique_Error_Tag
then
476 Write_Str
("error: ");
480 -- Here we have to split the message up into multiple lines
484 -- Make sure we do not have ludicrously small line
486 Max
:= Integer'Max (Max
, 20);
488 -- If remaining text fits, output it respecting LF and we are done
490 if Len
- Ptr
< Max
then
491 for J
in Ptr
.. Len
loop
492 if Txt
(J
) = ASCII
.LF
then
496 Write_Char
(Txt
(J
));
507 -- First scan forward looking for a hard end of line
509 for Scan
in Ptr
.. Ptr
+ Max
- 1 loop
510 if Txt
(Scan
) = ASCII
.LF
then
517 -- Otherwise scan backwards looking for a space
519 for Scan
in reverse Ptr
.. Ptr
+ Max
- 1 loop
520 if Txt
(Scan
) = ' ' then
527 -- If we fall through, no space, so split line arbitrarily
529 Split
:= Ptr
+ Max
- 1;
534 if Start
<= Split
then
535 Write_Line
(Txt
(Start
.. Split
));
539 Max
:= Integer (Length
- Column
+ 1);
547 procedure Purge_Messages
(From
: Source_Ptr
; To
: Source_Ptr
) is
550 function To_Be_Purged
(E
: Error_Msg_Id
) return Boolean;
551 -- Returns True for a message that is to be purged. Also adjusts
552 -- error counts appropriately.
558 function To_Be_Purged
(E
: Error_Msg_Id
) return Boolean is
561 and then Errors
.Table
(E
).Sptr
> From
562 and then Errors
.Table
(E
).Sptr
< To
564 if Errors
.Table
(E
).Warn
or else Errors
.Table
(E
).Style
then
565 Warnings_Detected
:= Warnings_Detected
- 1;
568 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
570 if Errors
.Table
(E
).Serious
then
571 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
582 -- Start of processing for Purge_Messages
585 while To_Be_Purged
(First_Error_Msg
) loop
586 First_Error_Msg
:= Errors
.Table
(First_Error_Msg
).Next
;
589 E
:= First_Error_Msg
;
590 while E
/= No_Error_Msg
loop
591 while To_Be_Purged
(Errors
.Table
(E
).Next
) loop
592 Errors
.Table
(E
).Next
:=
593 Errors
.Table
(Errors
.Table
(E
).Next
).Next
;
596 E
:= Errors
.Table
(E
).Next
;
604 function Same_Error
(M1
, M2
: Error_Msg_Id
) return Boolean is
605 Msg1
: constant String_Ptr
:= Errors
.Table
(M1
).Text
;
606 Msg2
: constant String_Ptr
:= Errors
.Table
(M2
).Text
;
608 Msg2_Len
: constant Integer := Msg2
'Length;
609 Msg1_Len
: constant Integer := Msg1
'Length;
615 (Msg1_Len
- 10 > Msg2_Len
617 Msg2
.all = Msg1
.all (1 .. Msg2_Len
)
619 Msg1
(Msg2_Len
+ 1 .. Msg2_Len
+ 10) = ", instance")
621 (Msg2_Len
- 10 > Msg1_Len
623 Msg1
.all = Msg2
.all (1 .. Msg1_Len
)
625 Msg2
(Msg1_Len
+ 1 .. Msg1_Len
+ 10) = ", instance");
632 procedure Set_Msg_Blank
is
635 and then Msg_Buffer
(Msglen
) /= ' '
636 and then Msg_Buffer
(Msglen
) /= '('
637 and then Msg_Buffer
(Msglen
) /= '-'
638 and then not Manual_Quote_Mode
644 -------------------------------
645 -- Set_Msg_Blank_Conditional --
646 -------------------------------
648 procedure Set_Msg_Blank_Conditional
is
651 and then Msg_Buffer
(Msglen
) /= ' '
652 and then Msg_Buffer
(Msglen
) /= '('
653 and then Msg_Buffer
(Msglen
) /= '"'
654 and then not Manual_Quote_Mode
658 end Set_Msg_Blank_Conditional
;
664 procedure Set_Msg_Char
(C
: Character) is
667 -- The check for message buffer overflow is needed to deal with cases
668 -- where insertions get too long (in particular a child unit name can
671 if Msglen
< Max_Msg_Length
then
672 Msglen
:= Msglen
+ 1;
673 Msg_Buffer
(Msglen
) := C
;
677 ---------------------------------
678 -- Set_Msg_Insertion_File_Name --
679 ---------------------------------
681 procedure Set_Msg_Insertion_File_Name
is
683 if Error_Msg_File_1
= No_File
then
686 elsif Error_Msg_File_1
= Error_File_Name
then
688 Set_Msg_Str
("<error>");
692 Get_Name_String
(Error_Msg_File_1
);
698 -- The following assignments ensure that the second and third {
699 -- insertion characters will correspond to the Error_Msg_File_2 and
700 -- Error_Msg_File_3 values and We suppress possible validity checks in
701 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
702 -- Error_Msg_File_3 is not needed and has not been set.
705 pragma Suppress
(Range_Check
);
707 Error_Msg_File_1
:= Error_Msg_File_2
;
708 Error_Msg_File_2
:= Error_Msg_File_3
;
710 end Set_Msg_Insertion_File_Name
;
712 -----------------------------------
713 -- Set_Msg_Insertion_Line_Number --
714 -----------------------------------
716 procedure Set_Msg_Insertion_Line_Number
(Loc
, Flag
: Source_Ptr
) is
717 Sindex_Loc
: Source_File_Index
;
718 Sindex_Flag
: Source_File_Index
;
721 -- Outputs "at " unless last characters in buffer are " from ". Certain
722 -- messages read better with from than at.
731 or else Msg_Buffer
(Msglen
- 5 .. Msglen
) /= " from "
737 -- Start of processing for Set_Msg_Insertion_Line_Number
742 if Loc
= No_Location
then
744 Set_Msg_Str
("unknown location");
746 elsif Loc
= System_Location
then
747 Set_Msg_Str
("in package System");
748 Set_Msg_Insertion_Run_Time_Name
;
750 elsif Loc
= Standard_Location
then
751 Set_Msg_Str
("in package Standard");
753 elsif Loc
= Standard_ASCII_Location
then
754 Set_Msg_Str
("in package Standard.ASCII");
757 -- Add "at file-name:" if reference is to other than the source
758 -- file in which the error message is placed. Note that we check
759 -- full file names, rather than just the source indexes, to
760 -- deal with generic instantiations from the current file.
762 Sindex_Loc
:= Get_Source_File_Index
(Loc
);
763 Sindex_Flag
:= Get_Source_File_Index
(Flag
);
765 if Full_File_Name
(Sindex_Loc
) /= Full_File_Name
(Sindex_Flag
) then
768 (Reference_Name
(Get_Source_File_Index
(Loc
)));
772 -- If in current file, add text "at line "
776 Set_Msg_Str
("line ");
779 -- Output line number for reference
781 Set_Msg_Int
(Int
(Get_Logical_Line_Number
(Loc
)));
783 -- Deal with the instantiation case. We may have a reference to,
784 -- e.g. a type, that is declared within a generic template, and
785 -- what we are really referring to is the occurrence in an instance.
786 -- In this case, the line number of the instantiation is also of
787 -- interest, and we add a notation:
791 -- where xxx is a line number output using this same routine (and
792 -- the recursion can go further if the instantiation is itself in
793 -- a generic template).
795 -- The flag location passed to us in this situation is indeed the
796 -- line number within the template, but as described in Sinput.L
797 -- (file sinput-l.ads, section "Handling Generic Instantiations")
798 -- we can retrieve the location of the instantiation itself from
799 -- this flag location value.
801 -- Note: this processing is suppressed if Suppress_Instance_Location
802 -- is set True. This is used to prevent redundant annotations of the
803 -- location of the instantiation in the case where we are placing
804 -- the messages on the instantiation in any case.
806 if Instantiation
(Sindex_Loc
) /= No_Location
807 and then not Suppress_Instance_Location
809 Set_Msg_Str
(", instance ");
810 Set_Msg_Insertion_Line_Number
(Instantiation
(Sindex_Loc
), Flag
);
813 end Set_Msg_Insertion_Line_Number
;
815 ----------------------------
816 -- Set_Msg_Insertion_Name --
817 ----------------------------
819 procedure Set_Msg_Insertion_Name
is
821 if Error_Msg_Name_1
= No_Name
then
824 elsif Error_Msg_Name_1
= Error_Name
then
826 Set_Msg_Str
("<error>");
829 Set_Msg_Blank_Conditional
;
830 Get_Unqualified_Decoded_Name_String
(Error_Msg_Name_1
);
832 -- Remove %s or %b at end. These come from unit names. If the
833 -- caller wanted the (unit) or (body), then they would have used
834 -- the $ insertion character. Certainly no error message should
835 -- ever have %b or %s explicitly occurring.
838 and then Name_Buffer
(Name_Len
- 1) = '%'
839 and then (Name_Buffer
(Name_Len
) = 'b'
841 Name_Buffer
(Name_Len
) = 's')
843 Name_Len
:= Name_Len
- 2;
846 -- Remove upper case letter at end, again, we should not be getting
847 -- such names, and what we hope is that the remainder makes sense.
850 and then Name_Buffer
(Name_Len
) in 'A' .. 'Z'
852 Name_Len
:= Name_Len
- 1;
855 -- If operator name or character literal name, just print it as is
856 -- Also print as is if it ends in a right paren (case of x'val(nnn))
858 if Name_Buffer
(1) = '"'
859 or else Name_Buffer
(1) = '''
860 or else Name_Buffer
(Name_Len
) = ')'
864 -- Else output with surrounding quotes in proper casing mode
867 Set_Casing
(Identifier_Casing
(Flag_Source
), Mixed_Case
);
874 -- The following assignments ensure that the second and third percent
875 -- insertion characters will correspond to the Error_Msg_Name_2 and
876 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
877 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
878 -- and has not been set.
881 pragma Suppress
(Range_Check
);
883 Error_Msg_Name_1
:= Error_Msg_Name_2
;
884 Error_Msg_Name_2
:= Error_Msg_Name_3
;
886 end Set_Msg_Insertion_Name
;
888 ------------------------------------
889 -- Set_Msg_Insertion_Name_Literal --
890 ------------------------------------
892 procedure Set_Msg_Insertion_Name_Literal
is
894 if Error_Msg_Name_1
= No_Name
then
897 elsif Error_Msg_Name_1
= Error_Name
then
899 Set_Msg_Str
("<error>");
903 Get_Name_String
(Error_Msg_Name_1
);
909 -- The following assignments ensure that the second and third % or %%
910 -- insertion characters will correspond to the Error_Msg_Name_2 and
911 -- Error_Msg_Name_3 values and We suppress possible validity checks in
912 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
913 -- Error_Msg_Name_3 is not needed and has not been set.
916 pragma Suppress
(Range_Check
);
918 Error_Msg_Name_1
:= Error_Msg_Name_2
;
919 Error_Msg_Name_2
:= Error_Msg_Name_3
;
921 end Set_Msg_Insertion_Name_Literal
;
923 -------------------------------------
924 -- Set_Msg_Insertion_Reserved_Name --
925 -------------------------------------
927 procedure Set_Msg_Insertion_Reserved_Name
is
929 Set_Msg_Blank_Conditional
;
930 Get_Name_String
(Error_Msg_Name_1
);
932 Set_Casing
(Keyword_Casing
(Flag_Source
), All_Lower_Case
);
935 end Set_Msg_Insertion_Reserved_Name
;
937 -------------------------------------
938 -- Set_Msg_Insertion_Reserved_Word --
939 -------------------------------------
941 procedure Set_Msg_Insertion_Reserved_Word
946 Set_Msg_Blank_Conditional
;
949 while J
<= Text
'Last and then Text
(J
) in 'A' .. 'Z' loop
950 Add_Char_To_Name_Buffer
(Text
(J
));
954 -- Here is where we make the special exception for RM
956 if Name_Len
= 2 and then Name_Buffer
(1 .. 2) = "RM" then
959 -- Not RM: case appropriately and add surrounding quotes
962 Set_Casing
(Keyword_Casing
(Flag_Source
), All_Lower_Case
);
967 end Set_Msg_Insertion_Reserved_Word
;
969 -------------------------------------
970 -- Set_Msg_Insertion_Run_Time_Name --
971 -------------------------------------
973 procedure Set_Msg_Insertion_Run_Time_Name
is
975 if Targparm
.Run_Time_Name_On_Target
/= No_Name
then
976 Set_Msg_Blank_Conditional
;
978 Get_Name_String
(Targparm
.Run_Time_Name_On_Target
);
979 Set_Casing
(Mixed_Case
);
980 Set_Msg_Str
(Name_Buffer
(1 .. Name_Len
));
983 end Set_Msg_Insertion_Run_Time_Name
;
985 ----------------------------
986 -- Set_Msg_Insertion_Uint --
987 ----------------------------
989 procedure Set_Msg_Insertion_Uint
is
992 UI_Image
(Error_Msg_Uint_1
);
994 for J
in 1 .. UI_Image_Length
loop
995 Set_Msg_Char
(UI_Image_Buffer
(J
));
998 -- The following assignment ensures that a second caret insertion
999 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1000 -- suppress possible validity checks in case operating in -gnatVa mode,
1001 -- and Error_Msg_Uint_2 is not needed and has not been set.
1004 pragma Suppress
(Range_Check
);
1006 Error_Msg_Uint_1
:= Error_Msg_Uint_2
;
1008 end Set_Msg_Insertion_Uint
;
1014 procedure Set_Msg_Int
(Line
: Int
) is
1017 Set_Msg_Int
(Line
/ 10);
1020 Set_Msg_Char
(Character'Val (Character'Pos ('0') + (Line
rem 10)));
1023 -------------------------
1024 -- Set_Msg_Name_Buffer --
1025 -------------------------
1027 procedure Set_Msg_Name_Buffer
is
1029 for J
in 1 .. Name_Len
loop
1030 Set_Msg_Char
(Name_Buffer
(J
));
1032 end Set_Msg_Name_Buffer
;
1038 procedure Set_Msg_Quote
is
1040 if not Manual_Quote_Mode
then
1049 procedure Set_Msg_Str
(Text
: String) is
1051 for J
in Text
'Range loop
1052 Set_Msg_Char
(Text
(J
));
1056 ------------------------------
1057 -- Set_Next_Non_Deleted_Msg --
1058 ------------------------------
1060 procedure Set_Next_Non_Deleted_Msg
(E
: in out Error_Msg_Id
) is
1062 if E
= No_Error_Msg
then
1067 E
:= Errors
.Table
(E
).Next
;
1068 exit when E
= No_Error_Msg
or else not Errors
.Table
(E
).Deleted
;
1071 end Set_Next_Non_Deleted_Msg
;
1073 ------------------------------
1074 -- Set_Specific_Warning_Off --
1075 ------------------------------
1077 procedure Set_Specific_Warning_Off
1083 Specific_Warnings
.Append
1085 Msg
=> new String'(Msg),
1086 Stop => Source_Last (Current_Source_File),
1090 end Set_Specific_Warning_Off;
1092 -----------------------------
1093 -- Set_Specific_Warning_On --
1094 -----------------------------
1096 procedure Set_Specific_Warning_On
1102 for J in 1 .. Specific_Warnings.Last loop
1104 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1106 if Msg = SWE.Msg.all
1107 and then Loc > SWE.Start
1109 and then Get_Source_File_Index (SWE.Start) =
1110 Get_Source_File_Index (Loc)
1116 -- If a config pragma is specifically cancelled, consider
1117 -- that it is no longer active as a configuration pragma.
1119 SWE.Config := False;
1126 end Set_Specific_Warning_On;
1128 ---------------------------
1129 -- Set_Warnings_Mode_Off --
1130 ---------------------------
1132 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1134 -- Don't bother with entries from instantiation copies, since we
1135 -- will already have a copy in the template, which is what matters
1137 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1141 -- If last entry in table already covers us, this is a redundant
1142 -- pragma Warnings (Off) and can be ignored. This also handles the
1143 -- case where all warnings are suppressed by command line switch.
1145 if Warnings.Last >= Warnings.First
1146 and then Warnings.Table (Warnings.Last).Start <= Loc
1147 and then Loc <= Warnings.Table (Warnings.Last).Stop
1151 -- Otherwise establish a new entry, extending from the location of
1152 -- the pragma to the end of the current source file. This ending
1153 -- point will be adjusted by a subsequent pragma Warnings (On).
1156 Warnings.Increment_Last;
1157 Warnings.Table (Warnings.Last).Start := Loc;
1158 Warnings.Table (Warnings.Last).Stop :=
1159 Source_Last (Current_Source_File);
1161 end Set_Warnings_Mode_Off;
1163 --------------------------
1164 -- Set_Warnings_Mode_On --
1165 --------------------------
1167 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1169 -- Don't bother with entries from instantiation copies, since we
1170 -- will already have a copy in the template, which is what matters
1172 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1176 -- Nothing to do unless command line switch to suppress all warnings
1177 -- is off, and the last entry in the warnings table covers this
1178 -- pragma Warnings (On), in which case adjust the end point.
1180 if (Warnings.Last >= Warnings.First
1181 and then Warnings.Table (Warnings.Last).Start <= Loc
1182 and then Loc <= Warnings.Table (Warnings.Last).Stop)
1183 and then Warning_Mode /= Suppress
1185 Warnings.Table (Warnings.Last).Stop := Loc;
1187 end Set_Warnings_Mode_On;
1189 ------------------------------------
1190 -- Test_Style_Warning_Serious_Msg --
1191 ------------------------------------
1193 procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1195 if Msg (Msg'First) = '\
' then
1199 Is_Serious_Error := True;
1200 Is_Warning_Msg := False;
1203 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1205 if Is_Style_Msg then
1206 Is_Serious_Error := False;
1209 for J in Msg'Range loop
1211 and then (J = Msg'First or else Msg (J - 1) /= ''')
1213 Is_Warning_Msg := True;
1216 and then (J = Msg'First or else Msg (J - 1) /= ''')
1218 Is_Warning_Msg := Error_Msg_Warn;
1221 and then (J = Msg'First or else Msg (J - 1) /= ''')
1223 Is_Serious_Error := False;
1227 if Is_Warning_Msg or Is_Style_Msg then
1228 Is_Serious_Error := False;
1230 end Test_Style_Warning_Serious_Msg;
1232 --------------------------------
1233 -- Validate_Specific_Warnings --
1234 --------------------------------
1236 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1238 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1240 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1242 if not SWE.Config then
1245 ("?pragma Warnings Off with no matching Warnings On",
1247 elsif not SWE.Used then
1249 ("?no warning suppressed by this pragma", SWE.Start);
1254 end Validate_Specific_Warnings;
1256 -------------------------------------
1257 -- Warning_Specifically_Suppressed --
1258 -------------------------------------
1260 function Warning_Specifically_Suppressed
1262 Msg : String_Ptr) return Boolean
1264 function Matches (S : String; P : String) return Boolean;
1265 -- Returns true if the String S patches the pattern P, which can contain
1266 -- wild card chars (*). The entire pattern must match the entire string.
1272 function Matches (S : String; P : String) return Boolean is
1273 Slast : constant Natural := S'Last;
1274 PLast : constant Natural := P'Last;
1276 SPtr : Natural := S'First;
1277 PPtr : Natural := P'First;
1280 -- Loop advancing through characters of string and pattern
1285 -- Return True if pattern is a single asterisk
1287 if PPtr = PLast and then P (PPtr) = '*' then
1290 -- Return True if both pattern and string exhausted
1292 elsif PPtr > PLast and then SPtr > Slast then
1295 -- Return False, if one exhausted and not the other
1297 elsif PPtr > PLast or else SPtr > Slast then
1300 -- Case where pattern starts with asterisk
1302 elsif P (PPtr) = '*' then
1304 -- Try all possible starting positions in S for match with
1305 -- the remaining characters of the pattern. This is the
1306 -- recursive call that implements the scanner backup.
1308 for J in SPtr .. Slast loop
1309 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1316 -- Dealt with end of string and *, advance if we have a match
1318 elsif S (SPtr) = P (PPtr) then
1322 -- If first characters do not match, that's decisive
1330 -- Start of processing for Warning_Specifically_Suppressed
1333 -- Loop through specific warning suppression entries
1335 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1337 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1340 -- Pragma applies if it is a configuration pragma, or if the
1341 -- location is in range of a specific non-configuration pragma.
1344 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1346 if Matches (Msg.all, SWE.Msg.all) then
1355 end Warning_Specifically_Suppressed;
1357 -------------------------
1358 -- Warnings_Suppressed --
1359 -------------------------
1361 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1363 if Warning_Mode = Suppress then
1367 -- Loop through table of ON/OFF warnings
1369 for J in Warnings.First .. Warnings.Last loop
1370 if Warnings.Table (J).Start <= Loc
1371 and then Loc <= Warnings.Table (J).Stop
1378 end Warnings_Suppressed;