1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 -- Warning! Error messages can be generated during Gigi processing by direct
27 -- calls to error message routines, so it is essential that the processing
28 -- in this body be consistent with the requirements for the Gigi processing
29 -- environment, and that in particular, no disallowed table expansion is
32 with Casing
; use Casing
;
33 with Debug
; use Debug
;
34 with Err_Vars
; use Err_Vars
;
35 with Namet
; use Namet
;
37 with Output
; use Output
;
38 with Sinput
; use Sinput
;
39 with Snames
; use Snames
;
40 with Targparm
; use Targparm
;
41 with Uintp
; use Uintp
;
43 package body Erroutc
is
49 procedure Add_Class
is
54 Get_Name_String
(Name_Class
);
55 Set_Casing
(Identifier_Casing
(Flag_Source
), Mixed_Case
);
60 ----------------------
61 -- Buffer_Ends_With --
62 ----------------------
64 function Buffer_Ends_With
(S
: String) return Boolean is
65 Len
: constant Natural := S
'Length;
69 and then Msg_Buffer
(Msglen
- Len
) = ' '
70 and then Msg_Buffer
(Msglen
- Len
+ 1 .. Msglen
) = S
;
77 procedure Buffer_Remove
(S
: String) is
79 if Buffer_Ends_With
(S
) then
80 Msglen
:= Msglen
- S
'Length;
84 -----------------------------
85 -- Check_Duplicate_Message --
86 -----------------------------
88 procedure Check_Duplicate_Message
(M1
, M2
: Error_Msg_Id
) is
89 L1
, L2
: Error_Msg_Id
;
90 N1
, N2
: Error_Msg_Id
;
92 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
);
93 -- Called to delete message Delete, keeping message Keep. Marks
94 -- all messages of Delete with deleted flag set to True, and also
95 -- makes sure that for the error messages that are retained the
96 -- preferred message is the one retained (we prefer the shorter
97 -- one in the case where one has an Instance tag). Note that we
98 -- always know that Keep has at least as many continuations as
99 -- Delete (since we always delete the shorter sequence).
105 procedure Delete_Msg
(Delete
, Keep
: Error_Msg_Id
) is
113 Errors
.Table
(D
).Deleted
:= True;
115 -- Adjust error message count
117 if Errors
.Table
(D
).Warn
or else Errors
.Table
(D
).Style
then
118 Warnings_Detected
:= Warnings_Detected
- 1;
121 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
123 if Errors
.Table
(D
).Serious
then
124 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
128 -- Substitute shorter of the two error messages
130 if Errors
.Table
(K
).Text
'Length > Errors
.Table
(D
).Text
'Length then
131 Errors
.Table
(K
).Text
:= Errors
.Table
(D
).Text
;
134 D
:= Errors
.Table
(D
).Next
;
135 K
:= Errors
.Table
(K
).Next
;
137 if D
= No_Error_Msg
or else not Errors
.Table
(D
).Msg_Cont
then
143 -- Start of processing for Check_Duplicate_Message
146 -- Both messages must be non-continuation messages and not deleted
148 if Errors
.Table
(M1
).Msg_Cont
149 or else Errors
.Table
(M2
).Msg_Cont
150 or else Errors
.Table
(M1
).Deleted
151 or else Errors
.Table
(M2
).Deleted
156 -- Definitely not equal if message text does not match
158 if not Same_Error
(M1
, M2
) then
162 -- Same text. See if all continuations are also identical
168 N1
:= Errors
.Table
(L1
).Next
;
169 N2
:= Errors
.Table
(L2
).Next
;
171 -- If M1 continuations have run out, we delete M1, either the
172 -- messages have the same number of continuations, or M2 has
173 -- more and we prefer the one with more anyway.
175 if N1
= No_Error_Msg
or else not Errors
.Table
(N1
).Msg_Cont
then
179 -- If M2 continuations have run out, we delete M2
181 elsif N2
= No_Error_Msg
or else not Errors
.Table
(N2
).Msg_Cont
then
185 -- Otherwise see if continuations are the same, if not, keep both
186 -- sequences, a curious case, but better to keep everything!
188 elsif not Same_Error
(N1
, N2
) then
191 -- If continuations are the same, continue scan
198 end Check_Duplicate_Message
;
200 ------------------------
201 -- Compilation_Errors --
202 ------------------------
204 function Compilation_Errors
return Boolean is
206 return Total_Errors_Detected
/= 0
207 or else (Warnings_Detected
/= 0
208 and then Warning_Mode
= Treat_As_Error
);
209 end Compilation_Errors
;
215 procedure Debug_Output
(N
: Node_Id
) is
218 Write_Str
("*** following error message posted on node id = #");
229 procedure dmsg
(Id
: Error_Msg_Id
) is
230 E
: Error_Msg_Object
renames Errors
.Table
(Id
);
233 w
("Dumping error message, Id = ", Int
(Id
));
234 w
(" Text = ", E
.Text
.all);
235 w
(" Next = ", Int
(E
.Next
));
236 w
(" Sfile = ", Int
(E
.Sfile
));
240 Write_Location
(E
.Sptr
);
245 Write_Location
(E
.Optr
);
248 w
(" Line = ", Int
(E
.Line
));
249 w
(" Col = ", Int
(E
.Col
));
250 w
(" Warn = ", E
.Warn
);
251 w
(" Style = ", E
.Style
);
252 w
(" Serious = ", E
.Serious
);
253 w
(" Uncond = ", E
.Uncond
);
254 w
(" Msg_Cont = ", E
.Msg_Cont
);
255 w
(" Deleted = ", E
.Deleted
);
264 function Get_Location
(E
: Error_Msg_Id
) return Source_Ptr
is
266 return Errors
.Table
(E
).Sptr
;
273 function Get_Msg_Id
return Error_Msg_Id
is
278 -----------------------
279 -- Output_Error_Msgs --
280 -----------------------
282 procedure Output_Error_Msgs
(E
: in out Error_Msg_Id
) is
288 Mult_Flags
: Boolean := False;
293 -- Skip deleted messages at start
295 if Errors
.Table
(S
).Deleted
then
296 Set_Next_Non_Deleted_Msg
(S
);
299 -- Figure out if we will place more than one error flag on this line
302 while T
/= No_Error_Msg
303 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
304 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
306 if Errors
.Table
(T
).Sptr
> Errors
.Table
(E
).Sptr
then
310 Set_Next_Non_Deleted_Msg
(T
);
313 -- Output the error flags. The circuit here makes sure that the tab
314 -- characters in the original line are properly accounted for. The
315 -- eight blanks at the start are to match the line number.
317 if not Debug_Flag_2
then
319 P
:= Line_Start
(Errors
.Table
(E
).Sptr
);
322 -- Loop through error messages for this line to place flags
325 while T
/= No_Error_Msg
326 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
327 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
329 -- Loop to output blanks till current flag position
331 while P
< Errors
.Table
(T
).Sptr
loop
332 if Source_Text
(Errors
.Table
(T
).Sfile
) (P
) = ASCII
.HT
then
333 Write_Char
(ASCII
.HT
);
341 -- Output flag (unless already output, this happens if more
342 -- than one error message occurs at the same flag position).
344 if P
= Errors
.Table
(T
).Sptr
then
345 if (Flag_Num
= 1 and then not Mult_Flags
)
350 Write_Char
(Character'Val (Character'Pos ('0') + Flag_Num
));
356 Set_Next_Non_Deleted_Msg
(T
);
357 Flag_Num
:= Flag_Num
+ 1;
363 -- Now output the error messages
366 while T
/= No_Error_Msg
367 and then Errors
.Table
(T
).Line
= Errors
.Table
(E
).Line
368 and then Errors
.Table
(T
).Sfile
= Errors
.Table
(E
).Sfile
374 while Column
< 74 loop
382 Set_Next_Non_Deleted_Msg
(T
);
386 end Output_Error_Msgs
;
388 ------------------------
389 -- Output_Line_Number --
390 ------------------------
392 procedure Output_Line_Number
(L
: Logical_Line_Number
) is
393 D
: Int
; -- next digit
394 C
: Character; -- next character
395 Z
: Boolean; -- flag for zero suppress
396 N
, M
: Int
; -- temporaries
399 if L
= No_Line_Number
then
420 C
:= Character'Val (D
+ 48);
428 end Output_Line_Number
;
430 ---------------------
431 -- Output_Msg_Text --
432 ---------------------
434 procedure Output_Msg_Text
(E
: Error_Msg_Id
) is
435 Offs
: constant Nat
:= Column
- 1;
436 -- Offset to start of message, used for continuations
439 -- Maximum characters to output on next line
442 -- Maximum total length of lines
444 Txt
: constant String_Ptr
:= Errors
.Table
(E
).Text
;
445 Len
: constant Natural := Txt
'Length;
451 if Error_Msg_Line_Length
= 0 then
454 Length
:= Error_Msg_Line_Length
;
457 Max
:= Integer (Length
- Column
+ 1);
459 -- For warning message, add "warning: " unless msg starts with "info: "
461 if Errors
.Table
(E
).Warn
then
462 if Len
< 6 or else Txt
(Txt
'First .. Txt
'First + 5) /= "info: " then
463 Write_Str
("warning: ");
467 -- No prefix needed for style message, since "(style)" is there already
469 elsif Errors
.Table
(E
).Style
then
472 -- All other cases, add "error: "
474 elsif Opt
.Unique_Error_Tag
then
475 Write_Str
("error: ");
479 -- Here we have to split the message up into multiple lines
483 -- Make sure we do not have ludicrously small line
485 Max
:= Integer'Max (Max
, 20);
487 -- If remaining text fits, output it respecting LF and we are done
489 if Len
- Ptr
< Max
then
490 for J
in Ptr
.. Len
loop
491 if Txt
(J
) = ASCII
.LF
then
495 Write_Char
(Txt
(J
));
506 -- First scan forward looking for a hard end of line
508 for Scan
in Ptr
.. Ptr
+ Max
- 1 loop
509 if Txt
(Scan
) = ASCII
.LF
then
516 -- Otherwise scan backwards looking for a space
518 for Scan
in reverse Ptr
.. Ptr
+ Max
- 1 loop
519 if Txt
(Scan
) = ' ' then
526 -- If we fall through, no space, so split line arbitrarily
528 Split
:= Ptr
+ Max
- 1;
533 if Start
<= Split
then
534 Write_Line
(Txt
(Start
.. Split
));
538 Max
:= Integer (Length
- Column
+ 1);
546 procedure Purge_Messages
(From
: Source_Ptr
; To
: Source_Ptr
) is
549 function To_Be_Purged
(E
: Error_Msg_Id
) return Boolean;
550 -- Returns True for a message that is to be purged. Also adjusts
551 -- error counts appropriately.
557 function To_Be_Purged
(E
: Error_Msg_Id
) return Boolean is
560 and then Errors
.Table
(E
).Sptr
> From
561 and then Errors
.Table
(E
).Sptr
< To
563 if Errors
.Table
(E
).Warn
or else Errors
.Table
(E
).Style
then
564 Warnings_Detected
:= Warnings_Detected
- 1;
567 Total_Errors_Detected
:= Total_Errors_Detected
- 1;
569 if Errors
.Table
(E
).Serious
then
570 Serious_Errors_Detected
:= Serious_Errors_Detected
- 1;
581 -- Start of processing for Purge_Messages
584 while To_Be_Purged
(First_Error_Msg
) loop
585 First_Error_Msg
:= Errors
.Table
(First_Error_Msg
).Next
;
588 E
:= First_Error_Msg
;
589 while E
/= No_Error_Msg
loop
590 while To_Be_Purged
(Errors
.Table
(E
).Next
) loop
591 Errors
.Table
(E
).Next
:=
592 Errors
.Table
(Errors
.Table
(E
).Next
).Next
;
595 E
:= Errors
.Table
(E
).Next
;
603 function Same_Error
(M1
, M2
: Error_Msg_Id
) return Boolean is
604 Msg1
: constant String_Ptr
:= Errors
.Table
(M1
).Text
;
605 Msg2
: constant String_Ptr
:= Errors
.Table
(M2
).Text
;
607 Msg2_Len
: constant Integer := Msg2
'Length;
608 Msg1_Len
: constant Integer := Msg1
'Length;
614 (Msg1_Len
- 10 > Msg2_Len
616 Msg2
.all = Msg1
.all (1 .. Msg2_Len
)
618 Msg1
(Msg2_Len
+ 1 .. Msg2_Len
+ 10) = ", instance")
620 (Msg2_Len
- 10 > Msg1_Len
622 Msg1
.all = Msg2
.all (1 .. Msg1_Len
)
624 Msg2
(Msg1_Len
+ 1 .. Msg1_Len
+ 10) = ", instance");
631 procedure Set_Msg_Blank
is
634 and then Msg_Buffer
(Msglen
) /= ' '
635 and then Msg_Buffer
(Msglen
) /= '('
636 and then Msg_Buffer
(Msglen
) /= '-'
637 and then not Manual_Quote_Mode
643 -------------------------------
644 -- Set_Msg_Blank_Conditional --
645 -------------------------------
647 procedure Set_Msg_Blank_Conditional
is
650 and then Msg_Buffer
(Msglen
) /= ' '
651 and then Msg_Buffer
(Msglen
) /= '('
652 and then Msg_Buffer
(Msglen
) /= '"'
653 and then not Manual_Quote_Mode
657 end Set_Msg_Blank_Conditional
;
663 procedure Set_Msg_Char
(C
: Character) is
666 -- The check for message buffer overflow is needed to deal with cases
667 -- where insertions get too long (in particular a child unit name can
670 if Msglen
< Max_Msg_Length
then
671 Msglen
:= Msglen
+ 1;
672 Msg_Buffer
(Msglen
) := C
;
676 ---------------------------------
677 -- Set_Msg_Insertion_File_Name --
678 ---------------------------------
680 procedure Set_Msg_Insertion_File_Name
is
682 if Error_Msg_File_1
= No_File
then
685 elsif Error_Msg_File_1
= Error_File_Name
then
687 Set_Msg_Str
("<error>");
691 Get_Name_String
(Error_Msg_File_1
);
697 -- The following assignments ensure that the second and third {
698 -- insertion characters will correspond to the Error_Msg_File_2 and
699 -- Error_Msg_File_3 values and We suppress possible validity checks in
700 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
701 -- Error_Msg_File_3 is not needed and has not been set.
704 pragma Suppress
(Range_Check
);
706 Error_Msg_File_1
:= Error_Msg_File_2
;
707 Error_Msg_File_2
:= Error_Msg_File_3
;
709 end Set_Msg_Insertion_File_Name
;
711 -----------------------------------
712 -- Set_Msg_Insertion_Line_Number --
713 -----------------------------------
715 procedure Set_Msg_Insertion_Line_Number
(Loc
, Flag
: Source_Ptr
) is
716 Sindex_Loc
: Source_File_Index
;
717 Sindex_Flag
: Source_File_Index
;
720 -- Outputs "at " unless last characters in buffer are " from ". Certain
721 -- messages read better with from than at.
730 or else Msg_Buffer
(Msglen
- 5 .. Msglen
) /= " from "
736 -- Start of processing for Set_Msg_Insertion_Line_Number
741 if Loc
= No_Location
then
743 Set_Msg_Str
("unknown location");
745 elsif Loc
= System_Location
then
746 Set_Msg_Str
("in package System");
747 Set_Msg_Insertion_Run_Time_Name
;
749 elsif Loc
= Standard_Location
then
750 Set_Msg_Str
("in package Standard");
752 elsif Loc
= Standard_ASCII_Location
then
753 Set_Msg_Str
("in package Standard.ASCII");
756 -- Add "at file-name:" if reference is to other than the source
757 -- file in which the error message is placed. Note that we check
758 -- full file names, rather than just the source indexes, to
759 -- deal with generic instantiations from the current file.
761 Sindex_Loc
:= Get_Source_File_Index
(Loc
);
762 Sindex_Flag
:= Get_Source_File_Index
(Flag
);
764 if Full_File_Name
(Sindex_Loc
) /= Full_File_Name
(Sindex_Flag
) then
767 (Reference_Name
(Get_Source_File_Index
(Loc
)));
771 -- If in current file, add text "at line "
775 Set_Msg_Str
("line ");
778 -- Output line number for reference
780 Set_Msg_Int
(Int
(Get_Logical_Line_Number
(Loc
)));
782 -- Deal with the instantiation case. We may have a reference to,
783 -- e.g. a type, that is declared within a generic template, and
784 -- what we are really referring to is the occurrence in an instance.
785 -- In this case, the line number of the instantiation is also of
786 -- interest, and we add a notation:
790 -- where xxx is a line number output using this same routine (and
791 -- the recursion can go further if the instantiation is itself in
792 -- a generic template).
794 -- The flag location passed to us in this situation is indeed the
795 -- line number within the template, but as described in Sinput.L
796 -- (file sinput-l.ads, section "Handling Generic Instantiations")
797 -- we can retrieve the location of the instantiation itself from
798 -- this flag location value.
800 -- Note: this processing is suppressed if Suppress_Instance_Location
801 -- is set True. This is used to prevent redundant annotations of the
802 -- location of the instantiation in the case where we are placing
803 -- the messages on the instantiation in any case.
805 if Instantiation
(Sindex_Loc
) /= No_Location
806 and then not Suppress_Instance_Location
808 Set_Msg_Str
(", instance ");
809 Set_Msg_Insertion_Line_Number
(Instantiation
(Sindex_Loc
), Flag
);
812 end Set_Msg_Insertion_Line_Number
;
814 ----------------------------
815 -- Set_Msg_Insertion_Name --
816 ----------------------------
818 procedure Set_Msg_Insertion_Name
is
820 if Error_Msg_Name_1
= No_Name
then
823 elsif Error_Msg_Name_1
= Error_Name
then
825 Set_Msg_Str
("<error>");
828 Set_Msg_Blank_Conditional
;
829 Get_Unqualified_Decoded_Name_String
(Error_Msg_Name_1
);
831 -- Remove %s or %b at end. These come from unit names. If the
832 -- caller wanted the (unit) or (body), then they would have used
833 -- the $ insertion character. Certainly no error message should
834 -- ever have %b or %s explicitly occurring.
837 and then Name_Buffer
(Name_Len
- 1) = '%'
838 and then (Name_Buffer
(Name_Len
) = 'b'
840 Name_Buffer
(Name_Len
) = 's')
842 Name_Len
:= Name_Len
- 2;
845 -- Remove upper case letter at end, again, we should not be getting
846 -- such names, and what we hope is that the remainder makes sense.
849 and then Name_Buffer
(Name_Len
) in 'A' .. 'Z'
851 Name_Len
:= Name_Len
- 1;
854 -- If operator name or character literal name, just print it as is
855 -- Also print as is if it ends in a right paren (case of x'val(nnn))
857 if Name_Buffer
(1) = '"'
858 or else Name_Buffer
(1) = '''
859 or else Name_Buffer
(Name_Len
) = ')'
863 -- Else output with surrounding quotes in proper casing mode
866 Set_Casing
(Identifier_Casing
(Flag_Source
), Mixed_Case
);
873 -- The following assignments ensure that the second and third percent
874 -- insertion characters will correspond to the Error_Msg_Name_2 and
875 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
876 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
877 -- and has not been set.
880 pragma Suppress
(Range_Check
);
882 Error_Msg_Name_1
:= Error_Msg_Name_2
;
883 Error_Msg_Name_2
:= Error_Msg_Name_3
;
885 end Set_Msg_Insertion_Name
;
887 ------------------------------------
888 -- Set_Msg_Insertion_Name_Literal --
889 ------------------------------------
891 procedure Set_Msg_Insertion_Name_Literal
is
893 if Error_Msg_Name_1
= No_Name
then
896 elsif Error_Msg_Name_1
= Error_Name
then
898 Set_Msg_Str
("<error>");
902 Get_Name_String
(Error_Msg_Name_1
);
908 -- The following assignments ensure that the second and third % or %%
909 -- insertion characters will correspond to the Error_Msg_Name_2 and
910 -- Error_Msg_Name_3 values and We suppress possible validity checks in
911 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
912 -- Error_Msg_Name_3 is not needed and has not been set.
915 pragma Suppress
(Range_Check
);
917 Error_Msg_Name_1
:= Error_Msg_Name_2
;
918 Error_Msg_Name_2
:= Error_Msg_Name_3
;
920 end Set_Msg_Insertion_Name_Literal
;
922 -------------------------------------
923 -- Set_Msg_Insertion_Reserved_Name --
924 -------------------------------------
926 procedure Set_Msg_Insertion_Reserved_Name
is
928 Set_Msg_Blank_Conditional
;
929 Get_Name_String
(Error_Msg_Name_1
);
931 Set_Casing
(Keyword_Casing
(Flag_Source
), All_Lower_Case
);
934 end Set_Msg_Insertion_Reserved_Name
;
936 -------------------------------------
937 -- Set_Msg_Insertion_Reserved_Word --
938 -------------------------------------
940 procedure Set_Msg_Insertion_Reserved_Word
945 Set_Msg_Blank_Conditional
;
948 while J
<= Text
'Last and then Text
(J
) in 'A' .. 'Z' loop
949 Add_Char_To_Name_Buffer
(Text
(J
));
953 -- Here is where we make the special exception for RM
955 if Name_Len
= 2 and then Name_Buffer
(1 .. 2) = "RM" then
958 -- We make a similar exception for Alfa
960 elsif Name_Len
= 4 and then Name_Buffer
(1 .. 4) = "Alfa" then
963 -- Neither RM nor Alfa: case appropriately and add surrounding quotes
966 Set_Casing
(Keyword_Casing
(Flag_Source
), All_Lower_Case
);
971 end Set_Msg_Insertion_Reserved_Word
;
973 -------------------------------------
974 -- Set_Msg_Insertion_Run_Time_Name --
975 -------------------------------------
977 procedure Set_Msg_Insertion_Run_Time_Name
is
979 if Targparm
.Run_Time_Name_On_Target
/= No_Name
then
980 Set_Msg_Blank_Conditional
;
982 Get_Name_String
(Targparm
.Run_Time_Name_On_Target
);
983 Set_Casing
(Mixed_Case
);
984 Set_Msg_Str
(Name_Buffer
(1 .. Name_Len
));
987 end Set_Msg_Insertion_Run_Time_Name
;
989 ----------------------------
990 -- Set_Msg_Insertion_Uint --
991 ----------------------------
993 procedure Set_Msg_Insertion_Uint
is
996 UI_Image
(Error_Msg_Uint_1
);
998 for J
in 1 .. UI_Image_Length
loop
999 Set_Msg_Char
(UI_Image_Buffer
(J
));
1002 -- The following assignment ensures that a second caret insertion
1003 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1004 -- suppress possible validity checks in case operating in -gnatVa mode,
1005 -- and Error_Msg_Uint_2 is not needed and has not been set.
1008 pragma Suppress
(Range_Check
);
1010 Error_Msg_Uint_1
:= Error_Msg_Uint_2
;
1012 end Set_Msg_Insertion_Uint
;
1018 procedure Set_Msg_Int
(Line
: Int
) is
1021 Set_Msg_Int
(Line
/ 10);
1024 Set_Msg_Char
(Character'Val (Character'Pos ('0') + (Line
rem 10)));
1027 -------------------------
1028 -- Set_Msg_Name_Buffer --
1029 -------------------------
1031 procedure Set_Msg_Name_Buffer
is
1033 for J
in 1 .. Name_Len
loop
1034 Set_Msg_Char
(Name_Buffer
(J
));
1036 end Set_Msg_Name_Buffer
;
1042 procedure Set_Msg_Quote
is
1044 if not Manual_Quote_Mode
then
1053 procedure Set_Msg_Str
(Text
: String) is
1055 for J
in Text
'Range loop
1056 Set_Msg_Char
(Text
(J
));
1060 ------------------------------
1061 -- Set_Next_Non_Deleted_Msg --
1062 ------------------------------
1064 procedure Set_Next_Non_Deleted_Msg
(E
: in out Error_Msg_Id
) is
1066 if E
= No_Error_Msg
then
1071 E
:= Errors
.Table
(E
).Next
;
1072 exit when E
= No_Error_Msg
or else not Errors
.Table
(E
).Deleted
;
1075 end Set_Next_Non_Deleted_Msg
;
1077 ------------------------------
1078 -- Set_Specific_Warning_Off --
1079 ------------------------------
1081 procedure Set_Specific_Warning_Off
1085 Used
: Boolean := False)
1088 Specific_Warnings
.Append
1090 Msg
=> new String'(Msg),
1091 Stop => Source_Last (Current_Source_File),
1095 end Set_Specific_Warning_Off;
1097 -----------------------------
1098 -- Set_Specific_Warning_On --
1099 -----------------------------
1101 procedure Set_Specific_Warning_On
1107 for J in 1 .. Specific_Warnings.Last loop
1109 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1111 if Msg = SWE.Msg.all
1112 and then Loc > SWE.Start
1114 and then Get_Source_File_Index (SWE.Start) =
1115 Get_Source_File_Index (Loc)
1121 -- If a config pragma is specifically cancelled, consider
1122 -- that it is no longer active as a configuration pragma.
1124 SWE.Config := False;
1131 end Set_Specific_Warning_On;
1133 ---------------------------
1134 -- Set_Warnings_Mode_Off --
1135 ---------------------------
1137 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1139 -- Don't bother with entries from instantiation copies, since we will
1140 -- already have a copy in the template, which is what matters.
1142 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1146 -- If last entry in table already covers us, this is a redundant pragma
1147 -- Warnings (Off) and can be ignored. This also handles the case where
1148 -- all warnings are suppressed by command line switch.
1150 if Warnings.Last >= Warnings.First
1151 and then Warnings.Table (Warnings.Last).Start <= Loc
1152 and then Loc <= Warnings.Table (Warnings.Last).Stop
1156 -- Otherwise establish a new entry, extending from the location of the
1157 -- pragma to the end of the current source file. This ending point will
1158 -- be adjusted by a subsequent pragma Warnings (On).
1161 Warnings.Increment_Last;
1162 Warnings.Table (Warnings.Last).Start := Loc;
1163 Warnings.Table (Warnings.Last).Stop :=
1164 Source_Last (Current_Source_File);
1166 end Set_Warnings_Mode_Off;
1168 --------------------------
1169 -- Set_Warnings_Mode_On --
1170 --------------------------
1172 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1174 -- Don't bother with entries from instantiation copies, since we will
1175 -- already have a copy in the template, which is what matters.
1177 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1181 -- Nothing to do unless command line switch to suppress all warnings
1182 -- is off, and the last entry in the warnings table covers this
1183 -- pragma Warnings (On), in which case adjust the end point.
1185 if (Warnings.Last >= Warnings.First
1186 and then Warnings.Table (Warnings.Last).Start <= Loc
1187 and then Loc <= Warnings.Table (Warnings.Last).Stop)
1188 and then Warning_Mode /= Suppress
1190 Warnings.Table (Warnings.Last).Stop := Loc;
1192 end Set_Warnings_Mode_On;
1194 ------------------------------------
1195 -- Test_Style_Warning_Serious_Msg --
1196 ------------------------------------
1198 procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1200 if Msg (Msg'First) = '\
' then
1204 Is_Serious_Error := True;
1205 Is_Warning_Msg := False;
1208 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1210 if Is_Style_Msg then
1211 Is_Serious_Error := False;
1214 for J in Msg'Range loop
1216 and then (J = Msg'First or else Msg (J - 1) /= ''')
1218 Is_Warning_Msg := True;
1221 and then (J = Msg'First or else Msg (J - 1) /= ''')
1223 Is_Warning_Msg := Error_Msg_Warn;
1226 and then (J = Msg'First or else Msg (J - 1) /= ''')
1228 Is_Serious_Error := False;
1232 if Is_Warning_Msg or Is_Style_Msg then
1233 Is_Serious_Error := False;
1235 end Test_Style_Warning_Serious_Msg;
1237 --------------------------------
1238 -- Validate_Specific_Warnings --
1239 --------------------------------
1241 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1243 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1245 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1247 if not SWE.Config then
1250 ("?pragma Warnings Off with no matching Warnings On",
1252 elsif not SWE.Used then
1254 ("?no warning suppressed by this pragma", SWE.Start);
1259 end Validate_Specific_Warnings;
1261 -------------------------------------
1262 -- Warning_Specifically_Suppressed --
1263 -------------------------------------
1265 function Warning_Specifically_Suppressed
1267 Msg : String_Ptr) return Boolean
1269 function Matches (S : String; P : String) return Boolean;
1270 -- Returns true if the String S patches the pattern P, which can contain
1271 -- wild card chars (*). The entire pattern must match the entire string.
1277 function Matches (S : String; P : String) return Boolean is
1278 Slast : constant Natural := S'Last;
1279 PLast : constant Natural := P'Last;
1281 SPtr : Natural := S'First;
1282 PPtr : Natural := P'First;
1285 -- Loop advancing through characters of string and pattern
1290 -- Return True if pattern is a single asterisk
1292 if PPtr = PLast and then P (PPtr) = '*' then
1295 -- Return True if both pattern and string exhausted
1297 elsif PPtr > PLast and then SPtr > Slast then
1300 -- Return False, if one exhausted and not the other
1302 elsif PPtr > PLast or else SPtr > Slast then
1305 -- Case where pattern starts with asterisk
1307 elsif P (PPtr) = '*' then
1309 -- Try all possible starting positions in S for match with
1310 -- the remaining characters of the pattern. This is the
1311 -- recursive call that implements the scanner backup.
1313 for J in SPtr .. Slast loop
1314 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1321 -- Dealt with end of string and *, advance if we have a match
1323 elsif S (SPtr) = P (PPtr) then
1327 -- If first characters do not match, that's decisive
1335 -- Start of processing for Warning_Specifically_Suppressed
1338 -- Loop through specific warning suppression entries
1340 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1342 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1345 -- Pragma applies if it is a configuration pragma, or if the
1346 -- location is in range of a specific non-configuration pragma.
1349 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1351 if Matches (Msg.all, SWE.Msg.all) then
1360 end Warning_Specifically_Suppressed;
1362 -------------------------
1363 -- Warnings_Suppressed --
1364 -------------------------
1366 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1368 if Warning_Mode = Suppress then
1372 -- Loop through table of ON/OFF warnings
1374 for J in Warnings.First .. Warnings.Last loop
1375 if Warnings.Table (J).Start <= Loc
1376 and then Loc <= Warnings.Table (J).Stop
1383 end Warnings_Suppressed;