[multiple changes]

2009-10-30  Bob Duff  <duff@adacore.com>

	* s-fileio.adb (Errno_Message): Suppress VMS-specific warning.

2009-10-30  Ed Schonberg  <schonberg@adacore.com>

	* 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  <dewar@adacore.com>

	* exp_aggr.adb, exp_ch9.adb: Minor reformatting

From-SVN: r153740

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  <duff@adacore.com>
+
+	* s-fileio.adb (Errno_Message): Suppress VMS-specific warning.
+
+2009-10-30  Ed Schonberg  <schonberg@adacore.com>
+
+	* 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  <dewar@adacore.com>
+
+	* exp_aggr.adb, exp_ch9.adb: Minor reformatting
+
 2009-10-29  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gcc-interface/decl.c (make_type_from_size) <INTEGER_TYPE>: 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)