From aaf44d5ae637a9b94975dbe08f00976e543bb78c Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 30 Oct 2009 11:57:55 +0000 Subject: [PATCH] 2009-10-30 Bob Duff * s-fileio.adb (Errno_Message): Suppress VMS-specific warning. 2009-10-30 Ed Schonberg * sem_case.adb (Check_Choices): Add explanatory message when there are missing alternatives when the required range of alternatives is given by the base type of the case expression or discriminant in a variant part. * opt.ads: New flag Warn_On_Overlap, to enable warnings on potentially dangerous overlap between actuals in a call, activated by -gnatw.i * sem_warn.adb (Set_Dot_Warning_Switch): set flag. (Warn_On_Overlapping_Actuals): use new flag. * gnat_ugn.texi: Document -gnatw.i, warning on overlapping actuals 2009-10-30 Robert Dewar * exp_aggr.adb, exp_ch9.adb: Minor reformatting git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153740 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 ++++++++ gcc/ada/exp_aggr.adb | 2 +- gcc/ada/exp_ch9.adb | 7 ++- gcc/ada/gnat_ugn.texi | 7 +++ gcc/ada/opt.ads | 5 ++ gcc/ada/s-fileio.adb | 5 ++ gcc/ada/sem_case.adb | 151 +++++++++++++++++++++++++++++++++++++------------- gcc/ada/sem_warn.adb | 27 ++++----- 8 files changed, 172 insertions(+), 54 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b07f23..f3315d7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2009-10-30 Bob Duff + + * s-fileio.adb (Errno_Message): Suppress VMS-specific warning. + +2009-10-30 Ed Schonberg + + * sem_case.adb (Check_Choices): Add explanatory message when there are + missing alternatives when the required range of alternatives is given + by the base type of the case expression or discriminant in a variant + part. + + * opt.ads: New flag Warn_On_Overlap, to enable warnings on potentially + dangerous overlap between actuals in a call, activated by -gnatw.i + * sem_warn.adb (Set_Dot_Warning_Switch): set flag. + (Warn_On_Overlapping_Actuals): use new flag. + + * gnat_ugn.texi: Document -gnatw.i, warning on overlapping actuals + +2009-10-30 Robert Dewar + + * exp_aggr.adb, exp_ch9.adb: Minor reformatting + 2009-10-29 Eric Botcazou * gcc-interface/decl.c (make_type_from_size) : Do not diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index aadb224..0e29af2 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -3302,7 +3302,7 @@ package body Exp_Aggr is elsif Needs_Finalization (Typ) then Flist := Find_Final_List (Access_Type); - -- Otherwise there are no controlled actions to be performed. + -- Otherwise there are no controlled actions to be performed. else Flist := Empty; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index f9cbf7b..7fe20b3 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -3983,13 +3983,16 @@ package body Exp_Ch9 is Spec_Id : Entity_Id; begin + -- Case of explicit task type, suffix TB + if Comes_From_Source (T) then - -- This is an explicit task type Spec_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (T), "TB")); + + -- Case of anonymous task type, suffix B + else - -- This is an anonymous task type Spec_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (T), 'B')); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 77d52eb..f4cae36 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -5268,6 +5268,13 @@ This warning can also be turned on using @option{-gnatwa}. This switch disables warnings for a @code{with} of an internal GNAT implementation unit. +@item -gnatw.i +@emph{Activate warnings on overlapping actuals.} +@cindex @option{-gnatw.i} (@command{gcc}) +This switch enables a warning on statically detectable overlapping actuals +in a subprogram call, when one of the actuals is an in-out parameter, and +the types of the actuals are not by-copy types. + @item -gnatwj @emph{Activate warnings on obsolescent features (Annex J).} @cindex @option{-gnatwj} (@command{gcc}) diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index d184da9..a71c823 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1361,6 +1361,11 @@ package Opt is -- Set to True to generate warnings on use of any feature in Annex or if a -- subprogram is called for which a pragma Obsolescent applies. + Warn_On_Overlap : Boolean := False; + -- GNAT + -- Set to True to generate warnings when a writable actual which is not + -- a by-copy type overlaps with another actual in a subprogram call. + Warn_On_Questionable_Missing_Parens : Boolean := True; -- GNAT -- Set to True to generate warnings for cases where parentheses are missing diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index d6cd2ad..f93fee2 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -375,8 +375,13 @@ package body System.File_IO is ------------------- function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is + pragma Warnings (Off); function To_Chars_Ptr is new Ada.Unchecked_Conversion (System.Address, chars_ptr); + -- On VMS, the compiler warns because System.Address is 64 bits, but + -- chars_ptr is 32 bits. It should be safe, though, because strerror + -- will return a 32-bit pointer. + pragma Warnings (On); Message : constant chars_ptr := To_Chars_Ptr (CRTL.strerror (Errno)); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 5de995d..0a342f9 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2009, 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- -- @@ -61,17 +61,24 @@ package body Sem_Case is procedure Check_Choices (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; + Subtyp : Entity_Id; Others_Present : Boolean; - Msg_Sloc : Source_Ptr); + Case_Node : Node_Id); -- This is the procedure which verifies that a set of case alternatives -- or record variant choices has no duplicates, and covers the range -- specified by Bounds_Type. Choice_Table contains the discrete choices -- to check. These must start at position 1. + -- -- Furthermore Choice_Table (0) must exist. This element is used by -- the sorting algorithm as a temporary. Others_Present is a flag -- indicating whether or not an Others choice is present. Finally -- Msg_Sloc gives the source location of the construct containing the -- choices in the Choice_Table. + -- + -- Bounds_Type is the type whose range must be covered by the alternatives + -- + -- Subtyp is the subtype of the expression. If its bounds are non-static + -- the alternatives must cover its base type. function Choice_Image (Value : Uint; Ctype : Entity_Id) return Name_Id; -- Given a Pos value of enumeration type Ctype, returns the name @@ -94,11 +101,17 @@ package body Sem_Case is ------------------- procedure Check_Choices - (Choice_Table : in out Sort_Choice_Table_Type; + (Choice_Table : in out Sort_Choice_Table_Type; Bounds_Type : Entity_Id; + Subtyp : Entity_Id; Others_Present : Boolean; - Msg_Sloc : Source_Ptr) + Case_Node : Node_Id) is + procedure Explain_Non_Static_Bound; + -- Called when we find a non-static bound, requiring the base type to + -- be covered. Provides where possible a helpful explanation of why the + -- bounds are non-static, since this is not always obvious. + function Lt_Choice (C1, C2 : Natural) return Boolean; -- Comparison routine for comparing Choice_Table entries. Use the lower -- bound of each Choice as the key. @@ -136,6 +149,8 @@ package body Sem_Case is end Issue_Msg; procedure Issue_Msg (Value1 : Uint; Value2 : Uint) is + Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); + begin -- In some situations, we call this with a null range, and -- obviously we don't want to complain in this case! @@ -191,17 +206,65 @@ package body Sem_Case is Choice_Table (Nat (To)) := Choice_Table (Nat (From)); end Move_Choice; + ------------------------------ + -- Explain_Non_Static_Bound -- + ------------------------------ + + procedure Explain_Non_Static_Bound is + Expr : Node_Id; + + begin + if Nkind (Case_Node) = N_Variant_Part then + Expr := Name (Case_Node); + else + Expr := Expression (Case_Node); + end if; + + if Bounds_Type /= Subtyp then + + -- If the case is a variant part, the expression is given by + -- the discriminant itself, and the bounds are the culprits. + + if Nkind (Case_Node) = N_Variant_Part then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + -- If this is a case statement, the expression may be + -- non-static or else the subtype may be at fault. + + elsif Is_Entity_Name (Expr) then + Error_Msg_NE + ("bounds of & are not static," & + " alternatives must cover base type", Expr, Expr); + + else + Error_Msg_N ("expression is not static," & + " alternatives must cover base type!", Expr); + end if; + + -- Otherwise the expression is not static, even if the bounds of the + -- type are, or else there are missing alternatives. If both, the + -- additional information may be redundant but harmless. + + elsif not Is_Entity_Name (Expr) then + Error_Msg_N + ("expression is not static, alternatives must cover base type!", + Expr); + end if; + end Explain_Non_Static_Bound; + -- Variables local to Check_Choices - Choice : Node_Id; - Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); - Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); + Choice : Node_Id; + Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); + Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type); Prev_Choice : Node_Id; - Hi : Uint; - Lo : Uint; - Prev_Hi : Uint; + Hi : Uint; + Lo : Uint; + Prev_Hi : Uint; -- Start of processing for Check_Choices @@ -216,6 +279,7 @@ package body Sem_Case is if not Others_Present then Issue_Msg (Bounds_Lo, Bounds_Hi); end if; + return; end if; @@ -227,6 +291,13 @@ package body Sem_Case is if not Others_Present and then Expr_Value (Bounds_Lo) < Lo then Issue_Msg (Bounds_Lo, Lo - 1); + + -- If values are missing outside of the subtype, add explanation. + -- No additional message if only one value is missing. + + if Expr_Value (Bounds_Lo) < Lo - 1 then + Explain_Non_Static_Bound; + end if; end if; for J in 2 .. Choice_Table'Last loop @@ -254,6 +325,10 @@ package body Sem_Case is if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then Issue_Msg (Hi + 1, Bounds_Hi); + + if Expr_Value (Bounds_Hi) > Hi + 1 then + Explain_Non_Static_Bound; + end if; end if; end Check_Choices; @@ -546,27 +621,27 @@ package body Sem_Case is Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); Choice_Type : constant Entity_Id := Base_Type (Subtyp); - -- The actual type against which the discrete choices are - -- resolved. Note that this type is always the base type not the - -- subtype of the ruling expression, index or discriminant. + -- The actual type against which the discrete choices are resolved. + -- Note that this type is always the base type not the subtype of the + -- ruling expression, index or discriminant. Bounds_Type : Entity_Id; - -- The type from which are derived the bounds of the values - -- covered by the discrete choices (see 3.8.1 (4)). If a discrete - -- choice specifies a value outside of these bounds we have an error. + -- The type from which are derived the bounds of the values covered + -- by the discrete choices (see 3.8.1 (4)). If a discrete choice + -- specifies a value outside of these bounds we have an error. Bounds_Lo : Uint; Bounds_Hi : Uint; -- The actual bounds of the above type Expected_Type : Entity_Id; - -- The expected type of each choice. Equal to Choice_Type, except - -- if the expression is universal, in which case the choices can - -- be of any integer type. + -- The expected type of each choice. Equal to Choice_Type, except if + -- the expression is universal, in which case the choices can be of + -- any integer type. Alt : Node_Id; -- A case statement alternative or a variant in a record type - -- declaration + -- declaration. Choice : Node_Id; Kind : Node_Kind; @@ -576,9 +651,9 @@ package body Sem_Case is -- Remember others choice if it is present (empty otherwise) procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); - -- Checks the validity of the bounds of a choice. When the bounds - -- are static and no error occurred the bounds are entered into - -- the choices table so that they can be sorted later on. + -- Checks the validity of the bounds of a choice. When the bounds + -- are static and no error occurred the bounds are entered into the + -- choices table so that they can be sorted later on. ----------- -- Check -- @@ -628,10 +703,10 @@ package body Sem_Case is if Lo_Val < Bounds_Lo then - -- If the choice is an entity name, then it is a type, and - -- we want to post the message on the reference to this - -- entity. Otherwise we want to post it on the lower bound - -- of the range. + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise we want to post it on the lower bound of the + -- range. if Is_Entity_Name (Choice) then Enode := Choice; @@ -654,10 +729,9 @@ package body Sem_Case is if Hi_Val > Bounds_Hi then - -- If the choice is an entity name, then it is a type, and - -- we want to post the message on the reference to this - -- entity. Otherwise we want to post it on the upper bound - -- of the range. + -- If the choice is an entity name, then it is a type, and we + -- want to post the message on the reference to this entity. + -- Otherwise post it on the upper bound of the range. if Is_Entity_Name (Choice) then Enode := Choice; @@ -678,9 +752,9 @@ package body Sem_Case is -- Store bounds in the table - -- Note: we still store the bounds, even if they are out of - -- range, since this may prevent unnecessary cascaded errors - -- for values that are covered by such an excessive range. + -- Note: we still store the bounds, even if they are out of range, + -- since this may prevent unnecessary cascaded errors for values + -- that are covered by such an excessive range. Last_Choice := Last_Choice + 1; Sort_Choice_Table (Last_Choice).Lo := Lo; @@ -695,9 +769,9 @@ package body Sem_Case is Raises_CE := False; Others_Present := False; - -- If Subtyp is not a static subtype Ada 95 requires then we use - -- the bounds of its base type to determine the values covered by - -- the discrete choices. + -- If Subtyp is not a static subtype Ada 95 requires then we use the + -- bounds of its base type to determine the values covered by the + -- discrete choices. if Is_OK_Static_Subtype (Subtyp) then Bounds_Type := Subtyp; @@ -848,8 +922,9 @@ package body Sem_Case is Check_Choices (Sort_Choice_Table (0 .. Last_Choice), Bounds_Type, + Subtyp, Others_Present or else (Choice_Type = Universal_Integer), - Sloc (N)); + N); -- Now copy the sorted discrete choices diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 12143c8..abfdf1f 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2991,6 +2991,7 @@ package body Sem_Warn is Warn_On_Non_Local_Exception := True; Warn_On_Object_Renames_Function := True; Warn_On_Obsolescent_Feature := True; + Warn_On_Overlap := True; Warn_On_Questionable_Missing_Parens := True; Warn_On_Redundant_Constructs := True; Warn_On_Unchecked_Conversion := True; @@ -3001,6 +3002,12 @@ package body Sem_Warn is when 'g' => Set_GNAT_Mode_Warnings; + when 'i' => + Warn_On_Overlap := True; + + when 'I' => + Warn_On_Overlap := False; + when 'm' => Warn_On_Suspicious_Modulus_Value := True; @@ -3139,6 +3146,7 @@ package body Sem_Warn is Warn_On_No_Value_Assigned := False; Warn_On_Non_Local_Exception := False; Warn_On_Obsolescent_Feature := False; + Warn_On_Overlap := False; Warn_On_All_Unread_Out_Parameters := False; Warn_On_Parameter_Order := False; Warn_On_Questionable_Missing_Parens := False; @@ -3544,11 +3552,7 @@ package body Sem_Warn is Form1, Form2 : Entity_Id; begin - -- For now, treat this warning as an extension - -- Why not just define a new warning switch, you really don't want to - -- force this warning when using conditional expressions for example??? - - if not Extensions_Allowed then + if not Warn_On_Overlap then return; end if; @@ -3582,10 +3586,6 @@ package body Sem_Warn is Denotes_Same_Prefix (Act1, Act2)) then -- Exclude generic types and guard against previous errors. - -- If either type is elementary the aliasing is harmless. - - -- I can't relate the comment about elementary to the - -- actual code below, which seems to be testing generic??? if Error_Posted (N) or else No (Etype (Act1)) @@ -3605,6 +3605,8 @@ package body Sem_Warn is elsif Nkind (Act2) = N_Function_Call then null; + -- If either type is elementary the aliasing is harmless. + elsif Is_Elementary_Type (Underlying_Type (Etype (Form1))) or else Is_Elementary_Type (Underlying_Type (Etype (Form2))) @@ -3626,10 +3628,9 @@ package body Sem_Warn is Next_Actual (Act); end loop; - -- If the call was written in prefix notation, count - -- only the visible actuals in the call. - - -- Why original_node calls below ??? + -- If the call was written in prefix notation, and + -- thus its prefix before rewriting was a selected + -- component, count only visible actuals in the call. if Is_Entity_Name (First_Actual (N)) and then Nkind (Original_Node (N)) = Nkind (N) -- 2.7.4