Skip to content

R
riscv-gcc-1
Commit e84a1961 by Robert Dewar Committed by Arnaud Charlet
Options

erroutc.ads, [...] (Set_Specific_Warning_On): New procedure 

2006-10-31  Robert Dewar  <dewar@adacore.com>

	* erroutc.ads, erroutc.adb (Set_Specific_Warning_On): New procedure
	(Set_Specific_Warning_Off): New procedure
	(Warning_Specifically_Suppressed): New function
	(Validate_Specific_Warnings): New procedure
	(Output_Msg_Text): Complete rewrite to support -gnatjnn

	* err_vars.ads: Implement insertion character ~ (insert string)

From-SVN: r118252
parent 4ecc031c
Showing with 400 additions and 12 deletions
gcc/ada/err_vars.ads
......@@ -132,4 +132,9 @@ package Err_Vars is
-- Used if current message contains a < insertion character to indicate
-- if the current message is a warning message.
Error_Msg_String : String (1 .. 4096);
Error_Msg_Strlen : Natural;
-- Used if current message contains a ~ insertion character to indicate
-- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen).
end Err_Vars;
gcc/ada/erroutc.adb
......@@ -43,10 +43,6 @@ with Uintp; use Uintp;
package body Erroutc is
-----------------------
-- Local Subprograms --
-----------------------
---------------
-- Add_Class --
---------------
......@@ -370,7 +366,6 @@ package body Erroutc is
while T /= No_Error_Msg
and then Errors.Table (T).Line = Errors.Table (E).Line
and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
loop
Write_Str (" >>> ");
Output_Msg_Text (T);
......@@ -437,18 +432,106 @@ package body Erroutc is
---------------------
procedure Output_Msg_Text (E : Error_Msg_Id) is
Offs : constant Nat := Column - 1;
-- Offset to start of message, used for continuations
Max : Integer;
-- Maximum characters to output on next line
Length : Nat;
-- Maximum total length of lines
begin
if Error_Msg_Line_Length = 0 then
Length := Nat'Last;
else
Length := Error_Msg_Line_Length;
end if;
Max := Integer (Length - Column + 1);
if Errors.Table (E).Warn then
Write_Str ("warning: ");
Max := Max - 9;
elsif Errors.Table (E).Style then
null;
elsif Opt.Unique_Error_Tag then
Write_Str ("error: ");
Max := Max - 7;
end if;
Write_Str (Errors.Table (E).Text.all);
-- Here we have to split the message up into multiple lines
declare
Txt : constant String_Ptr := Errors.Table (E).Text;
Len : constant Natural := Txt'Length;
Ptr : Natural;
Split : Natural;
Start : Natural;
begin
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
Max := Integer'Max (Max, 20);
-- If remaining text fits, output it respecting LF and we are done
if Len - Ptr < Max then
for J in Ptr .. Len loop
if Txt (J) = ASCII.LF then
Write_Eol;
Write_Spaces (Offs);
else
Write_Char (Txt (J));
end if;
end loop;
return;
-- Line does not fit
else
Start := Ptr;
-- First scan forward looing for a hard end of line
for Scan in Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ASCII.LF then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
end loop;
-- Otherwise scan backwards looking for a space
for Scan in reverse Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ' ' then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
end loop;
-- If we fall through, no space, so split line arbitrarily
Split := Ptr + Max - 1;
Ptr := Split + 1;
end if;
<<Continue>>
if Start <= Split then
Write_Line (Txt (Start .. Split));
Write_Spaces (Offs);
end if;
Max := Integer (Length - Column + 1);
end loop;
end;
end Output_Msg_Text;
--------------------
......@@ -916,6 +999,79 @@ package body Erroutc is
end if;
end Set_Next_Non_Deleted_Msg;
------------------------------
-- Set_Specific_Warning_Off --
------------------------------
procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String) is
pragma Assert (Msg'First = 1);
Pattern : String := Msg;
Patlen : Natural := Msg'Length;
Star_Start : Boolean;
Star_End : Boolean;
begin
if Pattern (1) = '*' then
Star_Start := True;
Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen);
Patlen := Patlen - 1;
else
Star_Start := False;
end if;
if Pattern (Patlen) = '*' then
Star_End := True;
Patlen := Patlen - 1;
else
Star_End := False;
end if;
Specific_Warnings.Increment_Last;
Specific_Warnings.Table (Specific_Warnings.Last) :=
(Start => Loc,
Msg => new String'(Msg),
Pattern => new String'(Pattern (1 .. Patlen)),
Patlen => Patlen,
Stop => Source_Last (Current_Source_File),
Open => True,
Used => False,
Star_Start => Star_Start,
Star_End => Star_End);
end Set_Specific_Warning_Off;
-----------------------------
-- Set_Specific_Warning_On --
-----------------------------
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
Msg : String;
Err : out Boolean)
is
begin
for J in 1 .. Specific_Warnings.Last loop
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
begin
if Msg = SWE.Msg.all
and then Loc > SWE.Start
and then SWE.Open
and then Get_Source_File_Index (SWE.Start) =
Get_Source_File_Index (Loc)
then
SWE.Stop := Loc;
SWE.Open := False;
Err := False;
return;
end if;
end;
end loop;
Err := True;
end Set_Specific_Warning_On;
---------------------------
-- Set_Warnings_Mode_Off --
---------------------------
......@@ -1017,12 +1173,154 @@ package body Erroutc is
end if;
end Test_Style_Warning_Serious_Msg;
--------------------------------
-- Validate_Specific_Warnings --
--------------------------------
procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
begin
for J in Specific_Warnings.First .. Specific_Warnings.Last loop
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
begin
if SWE.Start /= No_Location then
if SWE.Open then
Eproc.all
("?pragma Warnings Off with no matching Warnings On",
SWE.Start);
elsif not SWE.Used then
Eproc.all
("?no warning suppressed by this pragma", SWE.Start);
end if;
end if;
end;
end loop;
end Validate_Specific_Warnings;
-------------------------------------
-- Warning_Specifically_Suppressed --
-------------------------------------
function Warning_Specifically_Suppressed
(Loc : Source_Ptr;
Msg : String_Ptr) return Boolean
is
pragma Assert (Msg'First = 1);
Msglen : constant Natural := Msg'Length;
Patlen : Natural;
-- Length of message
Pattern : String_Ptr;
-- Pattern itself, excluding initial and final *
Star_Start : Boolean;
Star_End : Boolean;
-- Indications of * at start and end of original pattern
Msgp : Natural;
Patp : Natural;
-- Scan pointers for message and pattern
begin
-- Loop through specific warning suppression entries
for J in Specific_Warnings.First .. Specific_Warnings.Last loop
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
begin
-- See if location is in range
if SWE.Start = No_Location
or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
then
Patlen := SWE.Patlen;
Pattern := SWE.Pattern;
Star_Start := SWE.Star_Start;
Star_End := SWE.Star_End;
-- Loop through possible starting positions in Msg
Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
-- See if pattern matches string starting at Msg (J)
Msgp := M;
Patp := 1;
Inner : loop
-- If pattern exhausted, then match if we are at end
-- of message, or if pattern ended with an asterisk,
-- otherwise match failure at this position.
if Patp > Patlen then
if Msgp > Msglen or else Star_End then
SWE.Used := True;
return True;
else
exit Inner;
end if;
-- Otherwise if message exhausted (and we still have
-- pattern characters left), then match failure here.
elsif Msgp > Msglen then
exit Inner;
end if;
-- Here we have pattern and message characters left
-- Handle "*" pattern match
if Patp < Patlen - 1 and then
Pattern (Patp .. Patp + 2) = """*"""
then
Patp := Patp + 3;
-- Must have " and at least three chars in msg or we
-- have no match at this position.
exit Inner when Msg (Msgp) /= '"';
Msgp := Msgp + 1;
-- Scan out " string " in message
Scan : loop
exit Inner when Msgp = Msglen;
Msgp := Msgp + 1;
exit Scan when Msg (Msgp - 1) = '"';
end loop Scan;
-- If not "*" case, just compare character
else
exit Inner when Pattern (Patp) /= Msg (Msgp);
Patp := Patp + 1;
Msgp := Msgp + 1;
end if;
end loop Inner;
-- Advance to next position if star at end of original
-- pattern, otherwise no more match attempts are possible
exit Outer when not Star_Start;
end loop Outer;
end if;
end;
end loop;
return False;
end Warning_Specifically_Suppressed;
-------------------------
-- Warnings_Suppressed --
-------------------------
function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
begin
-- Loop through table of ON/OFF warnings
for J in Warnings.First .. Warnings.Last loop
if Warnings.Table (J).Start <= Loc
and then Loc <= Warnings.Table (J).Stop
......
gcc/ada/erroutc.ads
......@@ -41,6 +41,10 @@ package Erroutc is
-- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
-- insertion character is encountered.
Continuation_New_Line : Boolean := False;
-- Indicates if current message was a continuation line marked with \\ to
-- force a new line. Set True if \\ encountered.
Flag_Source : Source_File_Index;
-- Source file index for source file where error is being posted
......@@ -140,7 +144,8 @@ package Erroutc is
-- Text of error message, fully expanded with all insertions
Next : Error_Msg_Id;
-- Pointer to next message in error chain
-- Pointer to next message in error chain. A value of No_Error_Msg
-- indicates the end of the chain.
Sfile : Source_File_Index;
-- Source table index of source file. In the case of an error that
......@@ -218,9 +223,12 @@ package Erroutc is
--------------------------
-- Pragma Warnings allows warnings to be turned off for a specified
-- region of code, and the following tabl is the data structure used
-- region of code, and the following tables are the data structure used
-- to keep track of these regions.
-- The first table is used for the basic command line control, and for
-- the forms of Warning with a single ON or OFF parameter
-- It contains pairs of source locations, the first being the start
-- location for a warnings off region, and the second being the end
-- location. When a pragma Warnings (Off) is encountered, a new entry
......@@ -247,6 +255,49 @@ package Erroutc is
Table_Increment => 200,
Table_Name => "Warnings");
-- The second table is used for the specific forms of the pragma, where
-- the first argument is ON or OFF, and the second parameter is a string
-- which is the entire message to suppress, or a prefix of it.
type Specific_Warning_Entry is record
Start : Source_Ptr;
Stop : Source_Ptr;
-- Starting and ending source pointers for the range. These are always
-- from the same source file. Start is set to No_Location for the case
-- of a configuration pragma.
Msg : String_Ptr;
-- Message from pragma Warnings (Off, string)
Pattern : String_Ptr;
-- Same as Msg, excluding initial and final asterisks if present. The
-- lower bound of this string is always one.
Patlen : Natural;
-- Length of pattern string (excluding initial/final asterisks)
Open : Boolean;
-- Set to True if OFF has been encountered with no matchin ON
Used : Boolean;
-- Set to True if entry has been used to suppress a warning
Star_Start : Boolean;
-- True if given pattern had * at start
Star_End : Boolean;
-- True if given pattern had * at end
end record;
package Specific_Warnings is new Table.Table (
Table_Component_Type => Specific_Warning_Entry,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Specific_Warnings");
-----------------
-- Subprograms --
-----------------
......@@ -292,9 +343,11 @@ package Erroutc is
-- as all blanks, avoiding output of junk line numbers.
procedure Output_Msg_Text (E : Error_Msg_Id);
-- Outputs characters of text in the text of the error message E, excluding
-- any final exclamation point. Note that no end of line is output, the
-- caller is responsible for adding the end of line.
-- Outputs characters of text in the text of the error message E. Note that
-- no end of line is output, the caller is responsible for adding the end
-- of line. If Error_Msg_Line_Length is non-zero, this is the routine that
-- splits the line generating multiple lines of output, and in this case
-- the last line has no terminating end of line character.
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
-- All error messages whose location is in the range From .. To (not
......@@ -375,6 +428,24 @@ package Erroutc is
-- the input value of E was either already No_Error_Msg, or was the
-- last non-deleted message.
procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String);
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is OFF, and the second argument is the prefix
-- of a specific warning to be suppressed. The first argument is the start
-- of the suppression range, and the second argument is the string from
-- the pragma. Loc is set to No_Location for the configuration pragma case.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
Msg : String;
Err : out Boolean);
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is ON, and the second argument is the prefix
-- of a specific warning to be suppressed. The first argument is the end
-- of the suppression range, and the second argument is the string from
-- the pragma. Err is set to True on return to report the error of no
-- matching Warnings Off pragma preceding this one.
procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
-- Called in response to a pragma Warnings (Off) to record the source
-- location from which warnings are to be turned off.
......@@ -395,6 +466,20 @@ package Erroutc is
function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
-- Determines if given location is covered by a warnings off suppression
-- range in the warnings table (or is suppressed by compilation option,
-- which generates a warning range for the whole source file).
-- which generates a warning range for the whole source file). This routine
-- only deals with the general ON/OFF case, not specific warnings
function Warning_Specifically_Suppressed
(Loc : Source_Ptr;
Msg : String_Ptr) return Boolean;
-- Determines if given message to be posted at given location is suppressed
-- by specific ON/OFF Warnings pragmas specifying this particular message.
type Error_Msg_Proc is
access procedure (Msg : String; Flag_Location : Source_Ptr);
procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc);
-- Checks that specific warnings are consistent (for non-configuration
-- case, properly closed, and used). The argument is a pointer to the
-- Error_Msg procedure to be called if any inconsistencies are detected.
end Erroutc;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment