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
This commit is contained in:
Arnaud Charlet 2004-12-08 12:48:22 +01:00
parent 07233820c3
commit 6e73e3ab00
1 changed files with 68 additions and 43 deletions

View File

@ -145,25 +145,25 @@ package body Sem_Ch4 is
(L, R : Node_Id; (L, R : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id); N : Node_Id);
-- For the four varieties of concatenation. -- For the four varieties of concatenation
procedure Find_Equality_Types procedure Find_Equality_Types
(L, R : Node_Id; (L, R : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id); N : Node_Id);
-- Ditto for equality operators. -- Ditto for equality operators
procedure Find_Boolean_Types procedure Find_Boolean_Types
(L, R : Node_Id; (L, R : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id); N : Node_Id);
-- Ditto for binary logical operations. -- Ditto for binary logical operations
procedure Find_Negation_Types procedure Find_Negation_Types
(R : Node_Id; (R : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_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 procedure Find_Non_Universal_Interpretations
(N : Node_Id; (N : Node_Id;
@ -181,7 +181,7 @@ package body Sem_Ch4 is
(R : Node_Id; (R : Node_Id;
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id); N : Node_Id);
-- Unary arithmetic types: plus, minus, abs. -- Unary arithmetic types: plus, minus, abs
procedure Check_Arithmetic_Pair procedure Check_Arithmetic_Pair
(T1, T2 : Entity_Id; (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 -- for the type is not directly visible. The routine uses this type to emit
-- a more informative message. -- 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); procedure Remove_Abstract_Operations (N : Node_Id);
-- Ada 2005: implementation of AI-310. An abstract non-dispatching -- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation. -- operation is not a candidate interpretation.
@ -1235,7 +1243,7 @@ package body Sem_Ch4 is
End_Interp_List; 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 if Etype (N) = Any_Type then
Error_Msg_N Error_Msg_N
@ -1371,7 +1379,7 @@ package body Sem_Ch4 is
Exp : Node_Id; Exp : Node_Id;
Array_Type : Entity_Id; Array_Type : Entity_Id;
Index : Node_Id; Index : Node_Id;
Entry_Family : Entity_Id; Pent : Entity_Id := Empty;
begin begin
Exp := First (Exprs); Exp := First (Exprs);
@ -1382,38 +1390,32 @@ package body Sem_Ch4 is
else else
Array_Type := Etype (P); 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 if Is_Access_Type (Array_Type) then
Array_Type := Designated_Type (Array_Type); Array_Type := Designated_Type (Array_Type);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
Process_Implicit_Dereference_Prefix (Pent, P);
end if; end if;
if Is_Array_Type (Array_Type) then if Is_Array_Type (Array_Type) then
null; 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); Analyze (Exp);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
if not Has_Compatible_Type if not Has_Compatible_Type
(Exp, Entry_Index_Type (Entry_Family)) (Exp, Entry_Index_Type (Pent))
then then
Error_Msg_N ("invalid index type in entry name", N); Error_Msg_N ("invalid index type in entry name", N);
@ -1439,13 +1441,7 @@ package body Sem_Ch4 is
else else
if Nkind (Parent (N)) = N_Requeue_Statement 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 then
Error_Msg_N Error_Msg_N
("REQUEUE does not permit parameters", First (Exprs)); ("REQUEUE does not permit parameters", First (Exprs));
@ -2471,6 +2467,7 @@ package body Sem_Ch4 is
Comp : Entity_Id; Comp : Entity_Id;
Entity_List : Entity_Id; Entity_List : Entity_Id;
Prefix_Type : Entity_Id; Prefix_Type : Entity_Id;
Pent : Entity_Id := Empty;
Act_Decl : Node_Id; Act_Decl : Node_Id;
In_Scope : Boolean; In_Scope : Boolean;
Parent_N : Node_Id; Parent_N : Node_Id;
@ -2522,6 +2519,14 @@ package body Sem_Ch4 is
else else
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); 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; end if;
Prefix_Type := Designated_Type (Prefix_Type); Prefix_Type := Designated_Type (Prefix_Type);
@ -3961,10 +3966,9 @@ package body Sem_Ch4 is
Find_Non_Universal_Interpretations (N, R, Op_Id, T1); 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 if Etype (N) = Any_Type then
-- Operator was not visible.
Found := False; Found := False;
end if; end if;
end if; end if;
@ -4353,6 +4357,27 @@ package body Sem_Ch4 is
end if; end if;
end Operator_Check; 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 -- -- Remove_Abstract_Operations --
-------------------------------- --------------------------------
@ -4540,7 +4565,7 @@ package body Sem_Ch4 is
if No (It.Nam) then 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); Set_Etype (N, Any_Type);
Error_Msg_Sloc := Sloc (Abstract_Op); Error_Msg_Sloc := Sloc (Abstract_Op);
@ -4886,14 +4911,14 @@ package body Sem_Ch4 is
(Call_Node : Node_Id; (Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean Node_To_Replace : Node_Id) return Boolean
is 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 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)); Elmt := First_Elmt (Primitive_Operations (Obj_Type));
while Present (Elmt) loop while Present (Elmt) loop