sem_ch5.adb: Improve warnings on redundant assignments

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb: Improve warnings on redundant assignments

	* sem_util.ads, sem_util.adb: (Is_Variable): Add defense against junk
	parameter
	(Is_Synchronized_Tagged_Type): New subprogram that returns true
	in case of synchronized tagged types (AARM 3.9.4 (6/2)).
	(Safe_To_Capture_Value): Can now return True for constants, even if Cond
	is set to False. Improves handling of Known_[Not_]Null.
	(Wrong_Type): Special case address arithmetic attempt
	(Collect_Abstract_Interfaces): Add new formal to allow collecting
	abstract interfaces just using the partial view of private types.
	(Has_Abstract_Interfaces): Add new formal to allow checking types
	covering interfaces using the partial view of private types.
	(Is_Fully_Initialized_Type): Special VM case for uTag component. This
	component still needs to be defined in this case, but is never
	initialized as VMs are using other dispatching mechanisms.
	(Abstract_Interface_List): For a protected type, use base type to get
	proper declaration.
	Improve warnings on redundant assignments
	(Is_Variable): Handle properly an implicit dereference of a prefixed
	function call.
	(Build_Actual_Subtype): If this is an actual subtype for an
	unconstrained formal parameter, use the sloc of the body for the new
	declaration, to prevent anomalises in the debugger.

From-SVN: r127427

gcc/ada/sem_ch5.adb

@@ -250,7 +250,8 @@ package body Sem_Ch5 is
    --  Start of processing for Analyze_Assignment
 
    begin
-      Mark_Static_Coextensions (Rhs);
+      Mark_Coextensions (N, Rhs);
+
       Analyze (Rhs);
       Analyze (Lhs);
 
@@ -579,10 +580,10 @@ package body Sem_Ch5 is
         and then Can_Never_Be_Null (T1)
         and then not Assignment_OK (Lhs)
       then
-         if Nkind (Rhs) = N_Null then
+         if Known_Null (Rhs) then
             Apply_Compile_Time_Constraint_Error
               (N   => Rhs,
-               Msg => "(Ada 2005) NULL not allowed in null-excluding objects?",
+               Msg => "(Ada 2005) null not allowed in null-excluding objects?",
                Reason => CE_Null_Not_Allowed);
             return;
 
@@ -640,11 +641,9 @@ package body Sem_Ch5 is
 
          and then Comes_From_Source (N)
 
-         --  Where the entity is the same on both sides
+         --  Where the object is the same on both sides
 
-         and then Is_Entity_Name (Lhs)
-         and then Is_Entity_Name (Original_Node (Rhs))
-         and then Entity (Lhs) = Entity (Original_Node (Rhs))
+         and then Same_Object (Lhs, Original_Node (Rhs))
 
          --  But exclude the case where the right side was an operation
          --  that got rewritten (e.g. JUNK + K, where K was known to be
@@ -654,8 +653,13 @@ package body Sem_Ch5 is
 
         and then Nkind (Original_Node (Rhs)) not in N_Op
       then
-         Error_Msg_NE
-           ("?useless assignment of & to itself", N, Entity (Lhs));
+         if Nkind (Lhs) in N_Has_Entity then
+            Error_Msg_NE
+              ("?useless assignment of & to itself!", N, Entity (Lhs));
+         else
+            Error_Msg_N
+              ("?useless assignment of object to itself!", N);
+         end if;
       end if;
 
       --  Check for non-allowed composite assignment
@@ -1071,7 +1075,6 @@ package body Sem_Ch5 is
 
          begin
             Alt := First (Alternatives (N));
-
             while Present (Alt) loop
                if Alt /= Chosen then
                   Remove_Warning_Messages (Statements (Alt));
@@ -1341,7 +1344,6 @@ package body Sem_Ch5 is
 
             if Present (Elsif_Parts (N)) then
                E := First (Elsif_Parts (N));
-
                while Present (E) loop
                   Remove_Warning_Messages (Then_Statements (E));
                   Next (E);
@@ -2035,7 +2037,7 @@ package body Sem_Ch5 is
                --  the Ada RM annoyingly requires a useless return here!
 
                if Nkind (Original_Node (N)) /= N_Raise_Statement
-                 or else Nkind (Nxt) /= N_Return_Statement
+                 or else Nkind (Nxt) /= N_Simple_Return_Statement
                then
                   --  The rather strange shenanigans with the warning message
                   --  here reflects the fact that Kill_Dead_Code is very good
@@ -2077,7 +2079,7 @@ package body Sem_Ch5 is
 
                   --  Now issue the warning
 
-                  Error_Msg ("?unreachable code", Error_Loc);
+                  Error_Msg ("?unreachable code!", Error_Loc);
                end if;
 
             --  If the unconditional transfer of control instruction is

gcc/ada/sem_util.ads

@@ -28,6 +28,7 @@
 
 with Einfo;  use Einfo;
 with Namet;  use Namet;
+with Nmake;
 with Types;  use Types;
 with Uintp;  use Uintp;
 with Urealp; use Urealp;
@@ -147,10 +148,13 @@ package Sem_Util is
    procedure Collect_Abstract_Interfaces
      (T                         : Entity_Id;
       Ifaces_List               : out Elist_Id;
-      Exclude_Parent_Interfaces : Boolean := False);
+      Exclude_Parent_Interfaces : Boolean := False;
+      Use_Full_View             : Boolean := True);
    --  Ada 2005 (AI-251): Collect whole list of abstract interfaces that are
    --  directly or indirectly implemented by T. Exclude_Parent_Interfaces is
    --  used to avoid addition of inherited interfaces to the generated list.
+   --  Use_Full_View is used to collect the interfaces using the full-view
+   --  (if available).
 
    procedure Collect_Interface_Components
      (Tagged_Type     : Entity_Id;
@@ -158,6 +162,17 @@ package Sem_Util is
    --  Ada 2005 (AI-251): Collect all the tag components associated with the
    --  secondary dispatch tables of a tagged type.
 
+   procedure Collect_Interfaces_Info
+     (T               : Entity_Id;
+      Ifaces_List     : out Elist_Id;
+      Components_List : out Elist_Id;
+      Tags_List       : out Elist_Id);
+   --  Ada 2005 (AI-251): Collect all the interfaces associated with T plus
+   --  the record component and tag associated with each of these interfaces.
+   --  On exit Ifaces_List, Components_List and Tags_List have the same number
+   --  of elements, and elements at the same position on these tables provide
+   --  information on the same interface type.
+
    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
    --  Called upon type derivation and extension. We scan the declarative
    --  part in  which the type appears, and collect subprograms that have
@@ -282,7 +297,7 @@ package Sem_Util is
      (Def_Id      : Entity_Id;
       First_Hom   : Entity_Id;
       Ifaces_List : Elist_Id;
-      In_Scope    : Boolean := True) return Entity_Id;
+      In_Scope    : Boolean) return Entity_Id;
    --  Determine whether entry or subprogram Def_Id overrides a primitive
    --  operation that belongs to one of the interfaces in Ifaces_List. A
    --  specific homonym chain can be specified by setting First_Hom. Flag
@@ -443,8 +458,12 @@ package Sem_Util is
    --  Result of Has_Compatible_Alignment test, description found below. Note
    --  that the values are arranged in increasing order of problematicness.
 
-   function Has_Abstract_Interfaces (Tagged_Type : Entity_Id) return Boolean;
-   --  Returns true if Tagged_Type implements some abstract interface
+   function Has_Abstract_Interfaces
+     (Tagged_Type   : Entity_Id;
+      Use_Full_View : Boolean := True) return Boolean;
+   --  Returns true if Tagged_Type implements some abstract interface. In case
+   --  private types the argument Use_Full_View controls if the check is done
+   --  using its full view (if available).
 
    function Has_Compatible_Alignment
      (Obj  : Entity_Id;
@@ -689,6 +708,9 @@ package Sem_Util is
    --  the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
    --  Note that a label is *not* a statement, and will return False.
 
+   function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean;
+   --  Returns True if E is a synchronized tagged type (AARM 3.9.4 (6/2))
+
    function Is_Transfer (N : Node_Id) return Boolean;
    --  Returns True if the node N is a statement which is known to cause
    --  an unconditional transfer of control at runtime, i.e. the following
@@ -723,17 +745,16 @@ package Sem_Util is
    procedure Kill_Current_Values;
    --  This procedure is called to clear all constant indications from all
    --  entities in the current scope and in any parent scopes if the current
-   --  scope is a block or a package (and that recursion continues to the
-   --  top scope that is not a block or a package). This is used when the
-   --  sequential flow-of-control assumption is violated (occurence of a
-   --  label, head of a loop, or start of an exception handler). The effect
-   --  of the call is to clear the Constant_Value field (but we do not need
-   --  to clear the Is_True_Constant flag, since that only gets reset if
-   --  there really is an assignment somewhere in the entity scope). This
-   --  procedure also calls Kill_All_Checks, since this is a special case
-   --  of needing to forget saved values. This procedure also clears any
-   --  Is_Known_Non_Null flags in variables, constants or parameters
-   --  since these are also not known to be valid.
+   --  scope is a block or a package (and that recursion continues to the top
+   --  scope that is not a block or a package). This is used when the
+   --  sequential flow-of-control assumption is violated (occurence of a label,
+   --  head of a loop, or start of an exception handler). The effect of the
+   --  call is to clear the Constant_Value field (but we do not need to clear
+   --  the Is_True_Constant flag, since that only gets reset if there really is
+   --  an assignment somewhere in the entity scope). This procedure also calls
+   --  Kill_All_Checks, since this is a special case of needing to forget saved
+   --  values. This procedure also clears Is_Known_Non_Null flags in variables,
+   --  constants or parameters since these are also not known to be valid.
 
    procedure Kill_Current_Values (Ent : Entity_Id);
    --  This performs the same processing as described above for the form with
@@ -753,10 +774,27 @@ package Sem_Util is
    --  direction. Cases which may possibly be assignments but are not known to
    --  be may return True from May_Be_Lvalue, but False from this function.
 
-   procedure Mark_Static_Coextensions (Root_Node : Node_Id);
-   --  Perform a tree traversal starting from Root_Node while marking every
-   --  allocator as a static coextension. Cleanup for this action is performed
-   --  in Resolve_Allocator.
+   function Make_Simple_Return_Statement
+     (Sloc       : Source_Ptr;
+      Expression : Node_Id := Empty) return Node_Id
+     renames Nmake.Make_Return_Statement;
+   --  See Sinfo. We rename Make_Return_Statement to the correct Ada 2005
+   --  terminology here. Clients should use Make_Simple_Return_Statement.
+
+   Make_Return_Statement : constant := -2 ** 33;
+   --  Attempt to prevent accidental uses of Make_Return_Statement. If this
+   --  and the one in Nmake are both potentially use-visible, it will cause
+   --  a compilation error. Note that type and value are irrelevant.
+
+   N_Return_Statement : constant := -2**33;
+   --  Attempt to prevent accidental uses of N_Return_Statement; similar to
+   --  Make_Return_Statement above.
+
+   procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id);
+   --  Given a node which designates the context of analysis and an origin in
+   --  the tree, traverse from Root_Nod and mark all allocators as either
+   --  dynamic or static depending on Context_Nod. Any erroneous marking is
+   --  cleaned up during resolution.
 
    function May_Be_Lvalue (N : Node_Id) return Boolean;
    --  Determines if N could be an lvalue (e.g. an assignment left hand side).
@@ -911,7 +949,15 @@ package Sem_Util is
    --  capture actual value information, but we can capture conditional tests.
 
    function Same_Name (N1, N2 : Node_Id) return Boolean;
-   --  Determine if two (possibly expanded) names are the same name
+   --  Determine if two (possibly expanded) names are the same name. This is
+   --  a purely syntactic test, and N1 and N2 need not be analyzed.
+
+   function Same_Object (Node1, Node2 : Node_Id) return Boolean;
+   --  Determine if Node1 and Node2 are known to designate the same object.
+   --  This is a semantic test and both nodesmust be fully analyzed. A result
+   --  of True is decisively correct. A result of False does not necessarily
+   --  mean that different objects are designated, just that this could not
+   --  be reliably determined at compile time.
 
    function Same_Type (T1, T2 : Entity_Id) return Boolean;
    --  Determines if T1 and T2 represent exactly the same type. Two types
@@ -922,6 +968,13 @@ package Sem_Util is
    --  False is indecisive (e.g. the compiler may not be able to tell that
    --  two constraints are identical).
 
+   function Same_Value (Node1, Node2 : Node_Id) return Boolean;
+   --  Determines if Node1 and Node2 are known to be the same value, which is
+   --  true if they are both compile time known values and have the same value,
+   --  or if they are the same object (in the sense of function Same_Object).
+   --  A result of False does not necessarily mean they have different values,
+   --  just that it is not possible to determine they have the same value.
+
    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean;
    --  Determines if the entity Scope1 is the same as Scope2, or if it is
    --  inside it, where both entities represent scopes. Note that scopes
@@ -967,7 +1020,7 @@ package Sem_Util is
    --  value from T2 to T1. It does NOT copy the RM_Size field, which must be
    --  separately set if this is required to be copied also.
 
-   function Scope_Is_Transient  return Boolean;
+   function Scope_Is_Transient return Boolean;
    --  True if the current scope is transient
 
    function Static_Integer (N : Node_Id) return Uint;