sem_ch4.adb (Process_Implicit_Dereference_Prefix): New subprogram used to record an implicit dereference as a read operation on...

* sem_ch4.adb (Process_Implicit_Dereference_Prefix): New subprogram
	used to record an implicit dereference as a read operation on its
	prefix when operating under -gnatc. Necessary to avoid spurious
	'variable assigned but never read' warnings in that mode.
	(Process_Indexed_Component, Analyze_Selected_Component): When the prefix
	is a non-overloaded implicit dereference, call the above subprogram to
	ensure proper recording of references.

From-SVN: r91892

gcc/ada/sem_ch4.adb

@@ -145,25 +145,25 @@ package body Sem_Ch4 is
      (L, R  : Node_Id;
       Op_Id : Entity_Id;
       N     : Node_Id);
-   --  For the four varieties of concatenation.
+   --  For the four varieties of concatenation
 
    procedure Find_Equality_Types
      (L, R  : Node_Id;
       Op_Id : Entity_Id;
       N     : Node_Id);
-   --  Ditto for equality operators.
+   --  Ditto for equality operators
 
    procedure Find_Boolean_Types
      (L, R  : Node_Id;
       Op_Id : Entity_Id;
       N     : Node_Id);
-   --  Ditto for binary logical operations.
+   --  Ditto for binary logical operations
 
    procedure Find_Negation_Types
      (R     : Node_Id;
       Op_Id : Entity_Id;
       N     : Node_Id);
-   --  Find consistent interpretation for operand of negation operator.
+   --  Find consistent interpretation for operand of negation operator
 
    procedure Find_Non_Universal_Interpretations
      (N     : Node_Id;
@@ -181,7 +181,7 @@ package body Sem_Ch4 is
      (R     : Node_Id;
       Op_Id : Entity_Id;
       N     : Node_Id);
-   --  Unary arithmetic types: plus, minus, abs.
+   --  Unary arithmetic types: plus, minus, abs
 
    procedure Check_Arithmetic_Pair
      (T1, T2 : Entity_Id;
@@ -212,6 +212,14 @@ package body Sem_Ch4 is
    --  for the type is not directly visible. The routine uses this type to emit
    --  a more informative message.
 
+   procedure Process_Implicit_Dereference_Prefix
+     (E : Entity_Id; P : Node_Id);
+   --  Called when P is the prefix of an implicit dereference, denoting
+   --  an object E. If in semantics only mode (-gnatc), record that P
+   --  is a reference to E. Normally, such a reference is generated only
+   --  when the implicit dereference is expanded into an explicit one.
+   --  E may be empty, in which case this procedure does nothing.
+
    procedure Remove_Abstract_Operations (N : Node_Id);
    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
    --  operation is not a candidate interpretation.
@@ -1235,7 +1243,7 @@ package body Sem_Ch4 is
 
          End_Interp_List;
 
-         --  Error if no interpretation of the prefix has an access type.
+         --  Error if no interpretation of the prefix has an access type
 
          if Etype (N) = Any_Type then
             Error_Msg_N
@@ -1371,7 +1379,7 @@ package body Sem_Ch4 is
          Exp          : Node_Id;
          Array_Type   : Entity_Id;
          Index        : Node_Id;
-         Entry_Family : Entity_Id;
+         Pent         : Entity_Id := Empty;
 
       begin
          Exp := First (Exprs);
@@ -1382,38 +1390,32 @@ package body Sem_Ch4 is
          else
             Array_Type := Etype (P);
 
-            --  Prefix must be appropriate for an array type.
+            if Is_Entity_Name (P) then
-            --  Dereference the prefix if it is an access type.
+               Pent := Entity (P);
+            elsif Nkind (P) = N_Selected_Component
+              and then Is_Entity_Name (Selector_Name (P))
+            then
+               Pent := Entity (Selector_Name (P));
+            end if;
+
+            --  Prefix must be appropriate for an array type, taking into
+            --  account a possible implicit dereference.
 
             if Is_Access_Type (Array_Type) then
                Array_Type := Designated_Type (Array_Type);
                Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
+               Process_Implicit_Dereference_Prefix (Pent, P);
             end if;
 
             if Is_Array_Type (Array_Type) then
                null;
 
-            elsif (Is_Entity_Name (P)
+            elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
-                     and then
-                   Ekind (Entity (P)) = E_Entry_Family)
-               or else
-                 (Nkind (P) = N_Selected_Component
-                    and then
-                  Is_Entity_Name (Selector_Name (P))
-                    and then
-                  Ekind (Entity (Selector_Name (P))) = E_Entry_Family)
-            then
-               if Is_Entity_Name (P) then
-                  Entry_Family := Entity (P);
-               else
-                  Entry_Family := Entity (Selector_Name (P));
-               end if;
-
                Analyze (Exp);
                Set_Etype (N, Any_Type);
 
                if not Has_Compatible_Type
-                 (Exp, Entry_Index_Type (Entry_Family))
+                 (Exp, Entry_Index_Type (Pent))
                then
                   Error_Msg_N ("invalid index type in entry name", N);
 
@@ -1439,13 +1441,7 @@ package body Sem_Ch4 is
 
             else
                if Nkind (Parent (N)) = N_Requeue_Statement
-                 and then
+                 and then Present (Pent) and then Ekind (Pent) = E_Entry
-                   ((Is_Entity_Name (P)
-                        and then Ekind (Entity (P)) = E_Entry)
-                    or else
-                     (Nkind (P) = N_Selected_Component
-                       and then Is_Entity_Name (Selector_Name (P))
-                       and then Ekind (Entity (Selector_Name (P))) = E_Entry))
                then
                   Error_Msg_N
                     ("REQUEUE does not permit parameters", First (Exprs));
@@ -2471,6 +2467,7 @@ package body Sem_Ch4 is
       Comp        : Entity_Id;
       Entity_List : Entity_Id;
       Prefix_Type : Entity_Id;
+      Pent        : Entity_Id := Empty;
       Act_Decl    : Node_Id;
       In_Scope    : Boolean;
       Parent_N    : Node_Id;
@@ -2522,6 +2519,14 @@ package body Sem_Ch4 is
 
          else
             Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
+            if Is_Entity_Name (Name) then
+               Pent := Entity (Name);
+            elsif Nkind (Name) = N_Selected_Component
+              and then Is_Entity_Name (Selector_Name (Name))
+            then
+               Pent := Entity (Selector_Name (Name));
+            end if;
+            Process_Implicit_Dereference_Prefix (Pent, Name);
          end if;
 
          Prefix_Type := Designated_Type (Prefix_Type);
@@ -3961,10 +3966,9 @@ package body Sem_Ch4 is
 
             Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
 
+            --  Case of operator was not visible, Etype still set to Any_Type
+
             if Etype (N) = Any_Type then
-
-               --  Operator was not visible.
-
                Found := False;
             end if;
          end if;
@@ -4353,6 +4357,27 @@ package body Sem_Ch4 is
       end if;
    end Operator_Check;
 
+   -----------------------------------------
+   -- Process_Implicit_Dereference_Prefix --
+   -----------------------------------------
+
+   procedure Process_Implicit_Dereference_Prefix
+     (E : Entity_Id; P : Entity_Id)
+   is
+      Ref : Node_Id;
+   begin
+      if Operating_Mode = Check_Semantics and then Present (E) then
+         --  We create a dummy reference to E to ensure that the reference
+         --  is not considered as part of an assignment (an implicit
+         --  dereference can never assign to its prefix). The Comes_From_Source
+         --  attribute needs to be propagated for accurate warnings.
+
+         Ref := New_Reference_To (E, Sloc (P));
+         Set_Comes_From_Source (Ref, Comes_From_Source (P));
+         Generate_Reference (E, Ref);
+      end if;
+   end Process_Implicit_Dereference_Prefix;
+
    --------------------------------
    -- Remove_Abstract_Operations --
    --------------------------------
@@ -4540,7 +4565,7 @@ package body Sem_Ch4 is
 
             if No (It.Nam) then
 
-               --  Removal of abstract operation left no viable candidate.
+               --  Removal of abstract operation left no viable candidate
 
                Set_Etype (N, Any_Type);
                Error_Msg_Sloc := Sloc (Abstract_Op);
@@ -4886,14 +4911,14 @@ package body Sem_Ch4 is
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id) return Boolean
       is
-         Dummy          : Node_Id;
+         Dummy       : Node_Id;
-         Elmt           : Elmt_Id;
+         Elmt        : Elmt_Id;
-         Prim_Op        : Entity_Id;
+         Prim_Op     : Entity_Id;
-         Prim_Op_Ref    : Node_Id;
+         Prim_Op_Ref : Node_Id;
-         Success        : Boolean;
+         Success     : Boolean;
 
       begin
-         --  Look for the subprogram in the list of primitive operations.
+         --  Look for the subprogram in the list of primitive operations
 
          Elmt := First_Elmt (Primitive_Operations (Obj_Type));
          while Present (Elmt) loop