package body Erroutc is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
---------------
-- Add_Class --
---------------
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);
---------------------
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;
--------------------
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 --
---------------------------
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
-- 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
-- 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
--------------------------
-- 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
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 --
-----------------
-- 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
-- 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.
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;
projects / platform / upstream / linaro-gcc.git / commitdiff