From 554846f3b75d52bae87a1d076950eccf34846f4b Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 14 Aug 2007 10:37:51 +0200 Subject: [PATCH] comperr.adb: Fix problem with suppressing warning messages from gigi 2007-08-14 Robert Dewar * 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 --- gcc/ada/comperr.adb | 4 +-- gcc/ada/errout.ads | 52 +++++++++++++++++++++++++++----------- gcc/ada/erroutc.adb | 59 ++++++++++++++++++++++++++++++-------------- gcc/ada/erroutc.ads | 51 ++++++++++++++++++++++++++++---------- gcc/ada/exp_intr.adb | 2 +- gcc/ada/gnat1drv.adb | 27 ++++++++++++++------ gcc/ada/prepcomp.adb | 6 ++--- 7 files changed, 141 insertions(+), 60 deletions(-) diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 9b89852c4b6..3a23a92e778 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -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; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 9992cb4f5b2..704f2219730 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -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 diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 9c2a614f78d..6f928b02c28 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -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; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 292a9577d9c..998eb8e4846 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -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 diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index acbb8a792a8..dc36f4cc8f1 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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 diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index a08d8fcb4eb..1ae9d2ea2b9 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -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; diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb index 4a590e43701..41350b0d410 100644 --- a/gcc/ada/prepcomp.adb +++ b/gcc/ada/prepcomp.adb @@ -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),