OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

comperr.adb: Fix problem with suppressing warning messages from gigi

Browse Source 
2007-08-14  Robert Dewar  <dewar@adacore.com>

	* comperr.adb: Fix problem with suppressing warning messages from gigi

	* erroutc.ads, erroutc.adb, errout.ads, 
	errout.adb (Write_Eol): Remove trailing spaces before writing the line
	(Write_Eol_Keep_Blanks): New procedure to write a line, including
	possible trailing spaces.
	(Output_Source_Line): Call Write_Eol_Keep_Blanks to output a source line
	Fix problem with suppressing warning messages from back end
	Improve handling of deleted warnings

	* gnat1drv.adb: 
	Fix problem with suppressing warning messages from back end
	Handle setting of Static_Dispatch_Tables flag.

	* prepcomp.adb: 
	Fix problem with suppressing warning messages from back end

	* exp_intr.adb: Improve handling of deleted warnings

From-SVN: r127413
This commit is contained in:
Robert Dewar 2007-08-14 10:37:51 +02:00 committed by Arnaud Charlet
parent 8133b9d147
commit 554846f3b7
7 changed files with 141 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/comperr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -120,7 +120,7 @@ package body Comperr is
-- Debug flag K disables this behavior (useful for debugging)
if Serious_Errors_Detected /= 0 and then not Debug_Flag_K then
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Set_Standard_Error;

52
gcc/ada/errout.ads
View File

@ -204,7 +204,14 @@ package Errout is
--
-- By convention, the # insertion character is only used at the end of
-- an error message, so the above strings only appear as the last
-- characters of an error message.
-- characters of an error message. The only exceptions to this rule
-- are that an RM reference may follow in the form (RM .....) and a
-- right parenthesis may immediately follow the #. In the case of
-- continued messages, # can only appear at the end of a group of
-- continuation messsages, except that \\ messages which always start
-- a new line end the sequence from the point of view of this rule.
-- The idea is that for any use of -gnatj, it will still be the case
-- that a location reference appears only at the end of a line.
-- Insertion character } (Right brace: insert type reference)
-- The character } is replaced by a string describing the type
@ -244,8 +251,9 @@ package Errout is
-- the message unconditional which means that it is output even if it
-- would normally be suppressed. See section above for a description
-- of the cases in which messages are normally suppressed. Note that
-- warnings are never suppressed, so the use of the ! character in a
-- warning message is never useful.
-- in the case of warnings, the meaning is that the warning should not
-- be removed in dead code (that's the only time that the use of !
-- has any effect for a warning).
--
-- Note: the presence of ! is ignored in continuation messages (i.e.
-- messages starting with the \ insertion character). The effect of the
@ -456,6 +464,10 @@ package Errout is
-- used for keywords (actually the first compilation unit keyword) in the
-- source file.
-- Note: a special exception is that RM is never treated as a keyword
-- but instead is copied literally into the message, this avoids the
-- need for writing 'R'M for all reference manual quotes.
-- In the case of names, the default mode for the error text processor
-- is to surround the name by quotation marks automatically. The case
-- used for the identifier names is taken from the source program where
@ -560,18 +572,23 @@ package Errout is
-- Initializes for output of error messages. Must be called for each
-- source file before using any of the other routines in the package.
procedure Finalize;
procedure Finalize (Last_Call : Boolean);
-- Finalize processing of error message list. Includes processing for
-- duplicated error messages, and other similar final adjustment of the
-- list of error messages. Note that this procedure must be called before
-- calling Compilation_Errors to determine if there were any errors. It
-- is perfectly fine to call Finalize more than once. Indeed this can
-- make good sense. For example, do some processing that may generate
-- messages. Call Finalize to eliminate duplicates and remove deleted
-- warnings. Test for compilation errors using Compilation_Errors, then
-- generate some more errors/warnings, call Finalize again to make sure
-- that all duplicates in these new messages are dealt with, then finally
-- call Output_Messages to output the final list of messages.
-- is perfectly fine to call Finalize more than once, providing that the
-- parameter Last_Call is set False for every call except the last call.
-- This multiple call capability is used to do some processing that may
-- generate messages. Call Finalize to eliminate duplicates and remove
-- deleted warnings. Test for compilation errors using Compilation_Errors,
-- then generate some more errors/warnings, call Finalize again to make
-- sure that all duplicates in these new messages are dealt with, then
-- finally call Output_Messages to output the final list of messages. The
-- argument Last_Call must be set False on all calls except the last call,
-- and must be set True on the last call (a value of True activates some
-- processing that must only be done after all messages are posted).
procedure Output_Messages;
-- Output list of messages, including messages giving number of detected
@ -676,10 +693,14 @@ package Errout is
procedure Remove_Warning_Messages (N : Node_Id);
-- Remove any warning messages corresponding to the Sloc of N or any
-- of its descendent nodes. No effect if no such warnings.
-- of its descendent nodes. No effect if no such warnings. Note that
-- style messages (identified by the fact that they start with "(style)"
-- are not removed by this call. Basically the idea behind this procedure
-- is to remove warnings about execution conditions from known dead code.
procedure Remove_Warning_Messages (L : List_Id);
-- Remove warnings on all elements of a list
-- Remove warnings on all elements of a list (Calls Remove_Warning_Messages
-- on each element of the list, see above).
procedure Set_Ignore_Errors (To : Boolean);
-- Following a call to this procedure with To=True, all error calls are
@ -696,7 +717,10 @@ package Errout is
-- Called in response to a pragma Warnings (On) to record the source
-- location from which warnings are to be turned back on.
procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String)
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
Config : Boolean)
renames Erroutc.Set_Specific_Warning_Off;
-- 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

59
gcc/ada/erroutc.adb
View File

@ -924,10 +924,19 @@ package body Erroutc is
J := J + 1;
end loop;
Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
-- Here is where we make the special exception for RM
if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
Set_Msg_Name_Buffer;
-- Not RM: case appropriately and add surrounding quotes
else
Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
end if;
end Set_Msg_Insertion_Reserved_Word;
-------------------------------------
@ -1038,7 +1047,11 @@ package body Erroutc is
-- Set_Specific_Warning_Off --
------------------------------
procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String) is
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
Config : Boolean)
is
pragma Assert (Msg'First = 1);
Pattern : String := Msg;
@ -1063,17 +1076,17 @@ package body Erroutc is
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);
Specific_Warnings.Append
((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,
Config => Config));
end Set_Specific_Warning_Off;
-----------------------------
@ -1099,6 +1112,11 @@ package body Erroutc is
SWE.Stop := Loc;
SWE.Open := False;
Err := False;
-- If a config pragma is specifically cancelled, consider
-- that it is no longer active as a configuration pragma.
SWE.Config := False;
return;
end if;
end;
@ -1218,7 +1236,7 @@ package body Erroutc is
declare
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
begin
if SWE.Start /= No_Location then
if not SWE.Config then
if SWE.Open then
Eproc.all
("?pragma Warnings Off with no matching Warnings On",
@ -1265,11 +1283,14 @@ package body Erroutc is
SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
begin
-- See if location is in range
-- Pragma applies if it is a configuration pragma, or if the
-- location is in range of a specific non-configuration pragma.
if SWE.Start = No_Location
if SWE.Config
or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
then
-- Check if message matches, dealing with * patterns
Patlen := SWE.Patlen;
Pattern := SWE.Pattern;
Star_Start := SWE.Star_Start;

51
gcc/ada/erroutc.ads
View File

@ -263,8 +263,7 @@ package Erroutc is
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.
-- from the same source file.
Msg : String_Ptr;
-- Message from pragma Warnings (Off, string)
@ -277,7 +276,7 @@ package Erroutc is
-- Length of pattern string (excluding initial/final asterisks)
Open : Boolean;
-- Set to True if OFF has been encountered with no matchin ON
-- Set to True if OFF has been encountered with no matching ON
Used : Boolean;
-- Set to True if entry has been used to suppress a warning
@ -288,6 +287,10 @@ package Erroutc is
Star_End : Boolean;
-- True if given pattern had * at end
Config : Boolean;
-- True if pragma is configuration pragma (in which case no matching
-- Off pragma is required, and it is not required that a specific
-- warning be suppressed).
end record;
package Specific_Warnings is new Table.Table (
@ -298,6 +301,23 @@ package Erroutc is
Table_Increment => 200,
Table_Name => "Specific_Warnings");
-- Note on handling configuration case versus specific case. A complication
-- arises from this example:
-- pragma Warnings (Off, "not referenced*");
-- procedure Mumble (X : Integer) is
-- pragma Warnings (On, "not referenced*");
-- begin
-- null;
-- end Mumble;
-- The trouble is that the first pragma is technically a configuration
-- pragma, and yet it is clearly being used in the context of thinking
-- of it as a specific case. To deal with this, what we do is that the
-- On entry can match a configuration pragma from the same file, and if
-- we find such an On entry, we cancel the indication of it being the
-- configuration case. This seems to handle all cases we run into ok.
-----------------
-- Subprograms --
-----------------
@ -430,23 +450,28 @@ 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);
procedure Set_Specific_Warning_Off
(Loc : Source_Ptr;
Msg : String;
Config : Boolean);
-- 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.
-- where the first argument is OFF, and the second argument is a string
-- which identifies 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 the location of the pragma (which is the
-- start of the range to suppress). Config is True for the configuration
-- pragma case (where there is no requirement for a matching OFF pragma).
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.
-- where the first argument is ON, and the second argument is a string
-- which identifies 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

2
gcc/ada/exp_intr.adb
View File

@ -770,7 +770,7 @@ package body Exp_Intr is
begin
if No_Pool_Assigned (Rtyp) then
Error_Msg_N ("?deallocation from empty storage pool", N);
Error_Msg_N ("?deallocation from empty storage pool!", N);
end if;
-- Nothing to do if we know the argument is null

27
gcc/ada/gnat1drv.adb
View File

@ -171,7 +171,7 @@ procedure Gnat1drv is
and then not Source_File_Is_Subunit (Src_Ind)
and then not Source_File_Is_No_Body (Src_Ind)
then
Errout.Finalize;
Errout.Finalize (Last_Call => False);
Error_Msg_Unit_1 := Sname;
@ -338,6 +338,16 @@ begin
List_Representation_Info_Mechanisms := True;
end if;
-- Disable static allocation of dispatch tables if -gnatd.t or if layout
-- is enabled. The front end's layout phase currently treats types that
-- have discriminant-dependent arrays as not being static even when a
-- discriminant constraint on the type is static, and this leads to
-- problems with subtypes of type Ada.Tags.Dispatch_Table_Wrapper. ???
if Debug_Flag_Dot_T or else Frontend_Layout_On_Target then
Static_Dispatch_Tables := False;
end if;
-- Output copyright notice if full list mode unless we have a list
-- file, in which case we defer this so that it is output in the file
@ -417,7 +427,7 @@ begin
-- Exit with errors if the main source could not be parsed
if Sinput.Main_Source_File = No_Source_File then
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Exit_Program (E_Errors);
end if;
@ -428,7 +438,7 @@ begin
-- Exit if compilation errors detected
Errout.Finalize;
Errout.Finalize (Last_Call => False);
if Compilation_Errors then
Treepr.Tree_Dump;
@ -443,6 +453,7 @@ begin
Tree_Gen;
end if;
Errout.Finalize (Last_Call => True);
Exit_Program (E_Errors);
end if;
@ -466,7 +477,7 @@ begin
if Original_Operating_Mode = Check_Syntax then
Treepr.Tree_Dump;
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Tree_Gen;
Namet.Finalize;
@ -612,7 +623,7 @@ begin
Write_Eol;
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Treepr.Tree_Dump;
Tree_Gen;
@ -644,7 +655,7 @@ begin
or else Targparm.VM_Target /= No_VM)
then
Sem_Ch13.Validate_Unchecked_Conversions;
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Write_ALI (Object => False);
Tree_Dump;
@ -700,7 +711,7 @@ begin
-- indicating that elaboration is required, and also to back annotate
-- representation information for List_Rep_Info.
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
List_Rep_Info;
@ -758,7 +769,7 @@ begin
exception
when Unrecoverable_Error =>
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Set_Standard_Error;

6
gcc/ada/prepcomp.adb
View File

@ -41,7 +41,7 @@ with Types; use Types;
package body Prepcomp is
No_Preprocessing : Boolean := True;
-- Set to True if there is at least one source that needs to be
-- Set to False if there is at least one source that needs to be
-- preprocessed.
Source_Index_Of_Preproc_Data_File : Source_File_Index := No_Source_File;
@ -560,7 +560,7 @@ package body Prepcomp is
-- Fail if there were errors in the preprocessing data file
if Total_Errors_Detected > T then
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Fail ("errors found in preprocessing data file """,
Get_Name_String (N),
@ -687,7 +687,7 @@ package body Prepcomp is
-- Fail if errors were found while processing the definition file
if T /= Total_Errors_Detected then
Errout.Finalize;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Fail ("errors found in definition file """,
Get_Name_String (N),