OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_ch5.adb: Improve warnings on redundant assignments

Browse Source 
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
This commit is contained in:
Robert Dewar 2007-08-14 10:41:15 +02:00 committed by Arnaud Charlet
parent dc06abecbb
commit 1b6c95c49f
3 changed files with 493 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/ada/sem_ch5.adb
View File

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

480
gcc/ada/sem_util.adb
View File

@ -37,7 +37,6 @@ with Freeze; use Freeze;
with Lib; use Lib; with Lib; use Lib;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists; with Nlists; use Nlists;
with Nmake; use Nmake;
with Output; use Output; with Output; use Output;
with Opt; use Opt; with Opt; use Opt;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
@ -63,6 +62,8 @@ with Uname; use Uname;
package body Sem_Util is package body Sem_Util is
use Nmake;
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
@ -94,7 +95,13 @@ package body Sem_Util is
begin begin
if Is_Concurrent_Type (Typ) then if Is_Concurrent_Type (Typ) then
Nod := Parent (Typ);
-- If we are dealing with a synchronized subtype, go to the base
-- type, whose declaration has the interface list.
-- Shouldn't this be Declaration_Node???
Nod := Parent (Base_Type (Typ));
elsif Ekind (Typ) = E_Record_Type_With_Private then elsif Ekind (Typ) = E_Record_Type_With_Private then
if Nkind (Parent (Typ)) = N_Full_Type_Declaration then if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
@ -245,7 +252,9 @@ package body Sem_Util is
(T : Entity_Id; (T : Entity_Id;
N : Node_Or_Entity_Id) return Node_Id N : Node_Or_Entity_Id) return Node_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : Source_Ptr;
-- Normally Sloc (N), but may point to corresponding body in some cases
Constraints : List_Id; Constraints : List_Id;
Decl : Node_Id; Decl : Node_Id;
Discr : Entity_Id; Discr : Entity_Id;
@ -256,8 +265,28 @@ package body Sem_Util is
Obj : Node_Id; Obj : Node_Id;
begin begin
Loc := Sloc (N);
if Nkind (N) = N_Defining_Identifier then if Nkind (N) = N_Defining_Identifier then
Obj := New_Reference_To (N, Loc); Obj := New_Reference_To (N, Loc);
-- If this is a formal parameter of a subprogram declaration, and
-- we are compiling the body, we want the declaration for the
-- actual subtype to carry the source position of the body, to
-- prevent anomalies in gdb when stepping through the code.
if Is_Formal (N) then
declare
Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
begin
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Loc := Sloc (Corresponding_Body (Decl));
end if;
end;
end if;
else else
Obj := N; Obj := N;
end if; end if;
@ -1082,7 +1111,8 @@ package body Sem_Util is
procedure Collect_Abstract_Interfaces procedure Collect_Abstract_Interfaces
(T : Entity_Id; (T : Entity_Id;
Ifaces_List : out Elist_Id; Ifaces_List : out Elist_Id;
Exclude_Parent_Interfaces : Boolean := False) Exclude_Parent_Interfaces : Boolean := False;
Use_Full_View : Boolean := True)
is is
procedure Add_Interface (Iface : Entity_Id); procedure Add_Interface (Iface : Entity_Id);
-- Add the interface it if is not already in the list -- Add the interface it if is not already in the list
@ -1121,20 +1151,34 @@ package body Sem_Util is
------------- -------------
procedure Collect (Typ : Entity_Id) is procedure Collect (Typ : Entity_Id) is
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
Ancestor : Entity_Id; Ancestor : Entity_Id;
Full_T : Entity_Id;
Iface_List : List_Id;
Id : Node_Id; Id : Node_Id;
Iface : Entity_Id; Iface : Entity_Id;
begin begin
Full_T := Typ;
-- Handle private types
if Use_Full_View
and then Is_Private_Type (Typ)
and then Present (Full_View (Typ))
then
Full_T := Full_View (Typ);
end if;
Iface_List := Abstract_Interface_List (Full_T);
-- Include the ancestor if we are generating the whole list of -- Include the ancestor if we are generating the whole list of
-- abstract interfaces. -- abstract interfaces.
-- In concurrent types the ancestor interface (if any) is the -- In concurrent types the ancestor interface (if any) is the
-- first element of the list of interface types. -- first element of the list of interface types.
if Is_Concurrent_Type (Typ) if Is_Concurrent_Type (Full_T)
or else Is_Concurrent_Record_Type (Typ) or else Is_Concurrent_Record_Type (Full_T)
then then
if Is_Non_Empty_List (Iface_List) then if Is_Non_Empty_List (Iface_List) then
Ancestor := Etype (First (Iface_List)); Ancestor := Etype (First (Iface_List));
@ -1145,7 +1189,7 @@ package body Sem_Util is
end if; end if;
end if; end if;
elsif Etype (Typ) /= Typ elsif Etype (Full_T) /= Typ
-- Protect the frontend against wrong sources. For example: -- Protect the frontend against wrong sources. For example:
@ -1158,9 +1202,9 @@ package body Sem_Util is
-- type C is new B with null record; -- type C is new B with null record;
-- end P; -- end P;
and then Etype (Typ) /= T and then Etype (Full_T) /= T
then then
Ancestor := Etype (Typ); Ancestor := Etype (Full_T);
Collect (Ancestor); Collect (Ancestor);
if Is_Interface (Ancestor) if Is_Interface (Ancestor)
@ -1179,8 +1223,8 @@ package body Sem_Util is
-- first element of the list of interface types and we have -- first element of the list of interface types and we have
-- already processed them while climbing to the root type. -- already processed them while climbing to the root type.
if Is_Concurrent_Type (Typ) if Is_Concurrent_Type (Full_T)
or else Is_Concurrent_Record_Type (Typ) or else Is_Concurrent_Record_Type (Full_T)
then then
Next (Id); Next (Id);
end if; end if;
@ -1303,6 +1347,94 @@ package body Sem_Util is
Collect (Tagged_Type); Collect (Tagged_Type);
end Collect_Interface_Components; end Collect_Interface_Components;
-----------------------------
-- Collect_Interfaces_Info --
-----------------------------
procedure Collect_Interfaces_Info
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Components_List : out Elist_Id;
Tags_List : out Elist_Id)
is
Comps_List : Elist_Id;
Comp_Elmt : Elmt_Id;
Comp_Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface : Entity_Id;
function Search_Tag (Iface : Entity_Id) return Entity_Id;
-- Search for the secondary tag associated with the interface type
-- Iface that is implemented by T.
----------------
-- Search_Tag --
----------------
function Search_Tag (Iface : Entity_Id) return Entity_Id is
ADT : Elmt_Id;
begin
ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
while Present (ADT)
and then Ekind (Node (ADT)) = E_Constant
and then Related_Interface (Node (ADT)) /= Iface
loop
Next_Elmt (ADT);
end loop;
pragma Assert (Ekind (Node (ADT)) = E_Constant);
return Node (ADT);
end Search_Tag;
-- Start of processing for Collect_Interfaces_Info
begin
Collect_Abstract_Interfaces (T, Ifaces_List);
Collect_Interface_Components (T, Comps_List);
-- Search for the record component and tag associated with each
-- interface type of T.
Components_List := New_Elmt_List;
Tags_List := New_Elmt_List;
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
if Is_Parent (Iface, T) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
-- Otherwise search for the tag component and secondary dispatch
-- table of Iface
else
Comp_Elmt := First_Elmt (Comps_List);
while Present (Comp_Elmt) loop
Comp_Iface := Related_Interface (Node (Comp_Elmt));
if Comp_Iface = Iface
or else Is_Parent (Iface, Comp_Iface)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
exit;
end if;
Next_Elmt (Comp_Elmt);
end loop;
pragma Assert (Present (Comp_Elmt));
end if;
Next_Elmt (Iface_Elmt);
end loop;
end Collect_Interfaces_Info;
---------------------------------- ----------------------------------
-- Collect_Primitive_Operations -- -- Collect_Primitive_Operations --
---------------------------------- ----------------------------------
@ -1449,6 +1581,8 @@ package body Sem_Util is
Warn : Boolean := False) return Node_Id Warn : Boolean := False) return Node_Id
is is
Msgc : String (1 .. Msg'Length + 2); Msgc : String (1 .. Msg'Length + 2);
-- Copy of message, with room for possible ? and ! at end
Msgl : Natural; Msgl : Natural;
Wmsg : Boolean; Wmsg : Boolean;
P : Node_Id; P : Node_Id;
@ -1471,11 +1605,8 @@ package body Sem_Util is
Eloc := Sloc (N); Eloc := Sloc (N);
end if; end if;
-- Make all such messages unconditional
Msgc (1 .. Msg'Length) := Msg; Msgc (1 .. Msg'Length) := Msg;
Msgc (Msg'Length + 1) := '!'; Msgl := Msg'Length;
Msgl := Msg'Length + 1;
-- Message is a warning, even in Ada 95 case -- Message is a warning, even in Ada 95 case
@ -1499,9 +1630,15 @@ package body Sem_Util is
Wmsg := True; Wmsg := True;
-- Otherwise we have a real error message (Ada 95 static case) -- Otherwise we have a real error message (Ada 95 static case)
-- and we make this an unconditional message. Note that in the
-- warning case we do not make the message unconditional, it seems
-- quite reasonable to delete messages like this (about exceptions
-- that will be raised) in dead code.
else else
Wmsg := False; Wmsg := False;
Msgl := Msgl + 1;
Msgc (Msgl) := '!';
end if; end if;
-- Should we generate a warning? The answer is not quite yes. The -- Should we generate a warning? The answer is not quite yes. The
@ -2549,7 +2686,7 @@ package body Sem_Util is
(Def_Id : Entity_Id; (Def_Id : Entity_Id;
First_Hom : Entity_Id; First_Hom : Entity_Id;
Ifaces_List : Elist_Id; Ifaces_List : Elist_Id;
In_Scope : Boolean := True) return Entity_Id In_Scope : Boolean) return Entity_Id
is is
Candidate : Entity_Id := Empty; Candidate : Entity_Id := Empty;
Hom : Entity_Id := Empty; Hom : Entity_Id := Empty;
@ -2823,7 +2960,7 @@ package body Sem_Util is
-- After examining all candidates for overriding, we are left with -- After examining all candidates for overriding, we are left with
-- the best match which is a mode incompatible interface routine. -- the best match which is a mode incompatible interface routine.
-- Do not emit an error of the Expander is active since this error -- Do not emit an error if the Expander is active since this error
-- will be detected later on after all concurrent types are expanded -- will be detected later on after all concurrent types are expanded
-- and all wrappers are built. This check is meant for spec-only -- and all wrappers are built. This check is meant for spec-only
-- compilations. -- compilations.
@ -2833,23 +2970,26 @@ package body Sem_Util is
then then
Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate)));
-- Def_Id is primitive of a protected type, the candidate is -- Def_Id is primitive of a protected type, declared inside the type,
-- primitive of a limited or synchronized interface. -- and the candidate is primitive of a limited or synchronized
-- interface.
if Is_Protected_Type (Tag_Typ) if In_Scope
and then Is_Protected_Type (Tag_Typ)
and then and then
(Is_Limited_Interface (Iface_Typ) (Is_Limited_Interface (Iface_Typ)
or else Is_Protected_Interface (Iface_Typ) or else Is_Protected_Interface (Iface_Typ)
or else Is_Synchronized_Interface (Iface_Typ) or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ)) or else Is_Task_Interface (Iface_Typ))
then then
-- Must reword this message, comma before to in -gnatj mode ???
Error_Msg_NE Error_Msg_NE
("first formal of & must be of mode `OUT`, `IN OUT` or " & ("first formal of & must be of mode `OUT`, `IN OUT` or " &
"access-to-variable", Tag_Typ, Candidate); "access-to-variable", Tag_Typ, Candidate);
Error_Msg_N Error_Msg_N
("\to be overridden by protected procedure or entry " & ("\to be overridden by protected procedure or entry " &
"(`R`M 9.4(11))", Tag_Typ); "(RM 9.4(11.9/2))", Tag_Typ);
end if; end if;
end if; end if;
@ -3630,7 +3770,10 @@ package body Sem_Util is
-- Has_Abstract_Interfaces -- -- Has_Abstract_Interfaces --
----------------------------- -----------------------------
function Has_Abstract_Interfaces (Tagged_Type : Entity_Id) return Boolean is function Has_Abstract_Interfaces
(Tagged_Type : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
Typ : Entity_Id; Typ : Entity_Id;
begin begin
@ -3645,19 +3788,22 @@ package body Sem_Util is
return True; return True;
end if; end if;
Typ := Tagged_Type;
-- Handle private types -- Handle private types
if Present (Full_View (Tagged_Type)) then if Use_Full_View
and then Present (Full_View (Tagged_Type))
then
Typ := Full_View (Tagged_Type); Typ := Full_View (Tagged_Type);
else
Typ := Tagged_Type;
end if; end if;
loop loop
if Is_Interface (Typ) if Is_Interface (Typ)
or else (Present (Abstract_Interfaces (Typ)) or else
and then (Is_Record_Type (Typ)
not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) and then Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then then
return True; return True;
end if; end if;
@ -4276,7 +4422,7 @@ package body Sem_Util is
-- Or if expression obeys rules for preelaboration. For -- Or if expression obeys rules for preelaboration. For
-- now we approximate this by testing if the default -- now we approximate this by testing if the default
-- expression is a static expression or if it is an -- expression is a static expression or if it is an
-- access attribute reference. -- access attribute reference, or the literal null.
-- This is an approximation, it is probably incomplete??? -- This is an approximation, it is probably incomplete???
@ -4292,6 +4438,9 @@ package body Sem_Util is
then then
null; null;
elsif Nkind (Exp) = N_Null then
null;
else else
Has_PE := False; Has_PE := False;
exit; exit;
@ -5020,7 +5169,7 @@ package body Sem_Util is
-- Anonymous access discriminants carry a list of all nested -- Anonymous access discriminants carry a list of all nested
-- controlled coextensions. -- controlled coextensions.
and then not Is_Coextension (N) and then not Is_Dynamic_Coextension (N)
and then not Is_Static_Coextension (N); and then not Is_Static_Coextension (N);
end Is_Coextension_Root; end Is_Coextension_Root;
@ -5361,7 +5510,7 @@ package body Sem_Util is
Indx_Typ := Full_View (Indx_Typ); Indx_Typ := Full_View (Indx_Typ);
end if; end if;
if No (Indx_Typ) then if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
return False; return False;
else else
Lbd := Type_Low_Bound (Indx_Typ); Lbd := Type_Low_Bound (Indx_Typ);
@ -5449,6 +5598,14 @@ package body Sem_Util is
and then (No (Parent (Ent)) and then (No (Parent (Ent))
or else No (Expression (Parent (Ent)))) or else No (Expression (Parent (Ent))))
and then not Is_Fully_Initialized_Type (Etype (Ent)) and then not Is_Fully_Initialized_Type (Etype (Ent))
-- Special VM case for uTag component, which needs to be
-- defined in this case, but is never initialized as VMs
-- are using other dispatching mechanisms. Ignore this
-- uninitialized case.
and then (VM_Target = No_VM
or else Chars (Ent) /= Name_uTag)
then then
return False; return False;
end if; end if;
@ -5593,10 +5750,10 @@ package body Sem_Util is
function Is_Library_Level_Entity (E : Entity_Id) return Boolean is function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
begin begin
-- The following is a small optimization, and it also handles -- The following is a small optimization, and it also properly handles
-- properly discriminals, which in task bodies might appear in -- discriminals, which in task bodies might appear in expressions before
-- expressions before the corresponding procedure has been -- the corresponding procedure has been created, and which therefore do
-- created, and which therefore do not have an assigned scope. -- not have an assigned scope.
if Ekind (E) in Formal_Kind then if Ekind (E) in Formal_Kind then
return False; return False;
@ -5640,7 +5797,7 @@ package body Sem_Util is
function Is_Object_Reference (N : Node_Id) return Boolean is function Is_Object_Reference (N : Node_Id) return Boolean is
begin begin
if Is_Entity_Name (N) then if Is_Entity_Name (N) then
return Is_Object (Entity (N)); return Present (Entity (N)) and then Is_Object (Entity (N));
else else
case Nkind (N) is case Nkind (N) is
@ -6233,6 +6390,31 @@ package body Sem_Util is
or else Nkind (N) = N_Procedure_Call_Statement; or else Nkind (N) = N_Procedure_Call_Statement;
end Is_Statement; end Is_Statement;
---------------------------------
-- Is_Synchronized_Tagged_Type --
---------------------------------
function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
Kind : constant Entity_Kind := Ekind (Base_Type (E));
begin
-- A task or protected type derived from an interface is a tagged type.
-- Such a tagged type is called a synchronized tagged type, as are
-- synchronized interfaces and private extensions whose declaration
-- includes the reserved word synchronized.
return (Is_Tagged_Type (E)
and then (Kind = E_Task_Type
or else Kind = E_Protected_Type))
or else
(Is_Interface (E)
and then Is_Synchronized_Interface (E))
or else
(Ekind (E) = E_Record_Type_With_Private
and then (Synchronized_Present (Parent (E))
or else Is_Synchronized_Interface (Etype (E))));
end Is_Synchronized_Tagged_Type;
----------------- -----------------
-- Is_Transfer -- -- Is_Transfer --
----------------- -----------------
@ -6241,7 +6423,7 @@ package body Sem_Util is
Kind : constant Node_Kind := Nkind (N); Kind : constant Node_Kind := Nkind (N);
begin begin
if Kind = N_Return_Statement if Kind = N_Simple_Return_Statement
or else or else
Kind = N_Extended_Return_Statement Kind = N_Extended_Return_Statement
or else or else
@ -6384,12 +6566,19 @@ package body Sem_Util is
-- variable, even though the original node may not be (since it could -- variable, even though the original node may not be (since it could
-- be a constant of the access type). -- be a constant of the access type).
-- In Ada 2005 we have a further case to consider: the prefix may be
-- a function call given in prefix notation. The original node appears
-- to be a selected component, but we need to examine the call.
elsif Nkind (N) = N_Explicit_Dereference elsif Nkind (N) = N_Explicit_Dereference
and then Nkind (Orig_Node) /= N_Explicit_Dereference and then Nkind (Orig_Node) /= N_Explicit_Dereference
and then Present (Etype (Orig_Node)) and then Present (Etype (Orig_Node))
and then Is_Access_Type (Etype (Orig_Node)) and then Is_Access_Type (Etype (Orig_Node))
then then
return Is_Variable_Prefix (Original_Node (Prefix (N))); return Is_Variable_Prefix (Original_Node (Prefix (N)))
or else
(Nkind (Orig_Node) = N_Function_Call
and then not Is_Access_Constant (Etype (Prefix (N))));
-- A function call is never a variable -- A function call is never a variable
@ -6398,7 +6587,9 @@ package body Sem_Util is
-- All remaining checks use the original node -- All remaining checks use the original node
elsif Is_Entity_Name (Orig_Node) then elsif Is_Entity_Name (Orig_Node)
and then Present (Entity (Orig_Node))
then
declare declare
E : constant Entity_Id := Entity (Orig_Node); E : constant Entity_Id := Entity (Orig_Node);
K : constant Entity_Kind := Ekind (E); K : constant Entity_Kind := Ekind (E);
@ -6782,7 +6973,7 @@ package body Sem_Util is
when N_Attribute_Reference => when N_Attribute_Reference =>
return N = Prefix (P) return N = Prefix (P)
and then Name_Modifies_Prefix (Attribute_Name (P)); and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
when N_Expanded_Name | when N_Expanded_Name |
N_Explicit_Dereference | N_Explicit_Dereference |
@ -6897,13 +7088,15 @@ package body Sem_Util is
end case; end case;
end May_Be_Lvalue; end May_Be_Lvalue;
------------------------------ -----------------------
-- Mark_Static_Coextensions -- -- Mark_Coextensions --
------------------------------ -----------------------
procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
Is_Dynamic : Boolean := False;
procedure Mark_Static_Coextensions (Root_Node : Node_Id) is
function Mark_Allocator (N : Node_Id) return Traverse_Result; function Mark_Allocator (N : Node_Id) return Traverse_Result;
-- Recognize an allocator node and label it as a static coextension -- Recognize an allocator node and label it as a dynamic coextension
-------------------- --------------------
-- Mark_Allocator -- -- Mark_Allocator --
@ -6912,7 +7105,11 @@ package body Sem_Util is
function Mark_Allocator (N : Node_Id) return Traverse_Result is function Mark_Allocator (N : Node_Id) return Traverse_Result is
begin begin
if Nkind (N) = N_Allocator then if Nkind (N) = N_Allocator then
Set_Is_Static_Coextension (N); if Is_Dynamic then
Set_Is_Dynamic_Coextension (N);
else
Set_Is_Static_Coextension (N);
end if;
end if; end if;
return OK; return OK;
@ -6920,16 +7117,26 @@ package body Sem_Util is
procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
-- Start of processing for Mark_Static_Coextensions -- Start of processing Mark_Coextensions
begin begin
-- Do not mark allocators that stem from an initial allocator because case Nkind (Context_Nod) is
-- these will never be static. when N_Assignment_Statement |
N_Simple_Return_Statement =>
Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
if Nkind (Root_Node) /= N_Allocator then when N_Object_Declaration =>
Mark_Allocators (Root_Node); Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
end if;
end Mark_Static_Coextensions; -- This routine should not be called for constructs which may not
-- contain coextensions.
when others =>
raise Program_Error;
end case;
Mark_Allocators (Root_Nod);
end Mark_Coextensions;
---------------------- ----------------------
-- Needs_One_Actual -- -- Needs_One_Actual --
@ -7082,7 +7289,7 @@ package body Sem_Util is
Success : out Boolean) Success : out Boolean)
is is
Actuals : constant List_Id := Parameter_Associations (N); Actuals : constant List_Id := Parameter_Associations (N);
Actual : Node_Id := Empty; Actual : Node_Id := Empty;
Formal : Entity_Id; Formal : Entity_Id;
Last : Node_Id := Empty; Last : Node_Id := Empty;
First_Named : Node_Id := Empty; First_Named : Node_Id := Empty;
@ -8089,26 +8296,30 @@ package body Sem_Util is
Cond : Boolean := False) return Boolean Cond : Boolean := False) return Boolean
is is
begin begin
-- The only entities for which we track constant values are variables, -- The only entities for which we track constant values are variables
-- which are not renamings, out parameters and in out parameters, so -- which are not renamings, constants, out parameters, and in out
-- check if we have this case. -- parameters, so check if we have this case.
-- Note: it may seem odd to track constant values for constants, but in
-- fact this routine is used for other purposes than simply capturing
-- the value. In particular, the setting of Known[_Non]_Null.
if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
or else or else
Ekind (Ent) = E_Out_Parameter Ekind (Ent) = E_Constant
or else or else
Ekind (Ent) = E_In_Out_Parameter Ekind (Ent) = E_Out_Parameter
or else
Ekind (Ent) = E_In_Out_Parameter
then then
null; null;
-- For conditionals, we also allow constants, loop parameters and all -- For conditionals, we also allow loop parameters and all formals,
-- formals, including in parameters. -- including in parameters.
elsif Cond elsif Cond
and then and then
(Ekind (Ent) = E_Constant (Ekind (Ent) = E_Loop_Parameter
or else
Ekind (Ent) = E_Loop_Parameter
or else or else
Ekind (Ent) = E_In_Parameter) Ekind (Ent) = E_In_Parameter)
then then
@ -8122,10 +8333,9 @@ package body Sem_Util is
return False; return False;
end if; end if;
-- Skip volatile and aliased variables, since funny things might -- Skip if volatile or aliased, since funny things might be going on in
-- be going on in these cases which we cannot necessarily track. -- these cases which we cannot necessarily track. Also skip any variable
-- Also skip any variable for which an address clause is given, -- for which an address clause is given, or whose address is taken.
-- or whose address is taken
if Treat_As_Volatile (Ent) if Treat_As_Volatile (Ent)
or else Is_Aliased (Ent) or else Is_Aliased (Ent)
@ -8135,9 +8345,9 @@ package body Sem_Util is
return False; return False;
end if; end if;
-- OK, all above conditions are met. We also require that the scope -- OK, all above conditions are met. We also require that the scope of
-- of the reference be the same as the scope of the entity, not -- the reference be the same as the scope of the entity, not counting
-- counting packages and blocks and loops. -- packages and blocks and loops.
declare declare
E_Scope : constant Entity_Id := Scope (Ent); E_Scope : constant Entity_Id := Scope (Ent);
@ -8227,6 +8437,84 @@ package body Sem_Util is
end if; end if;
end Same_Name; end Same_Name;
-----------------
-- Same_Object --
-----------------
function Same_Object (Node1, Node2 : Node_Id) return Boolean is
N1 : constant Node_Id := Original_Node (Node1);
N2 : constant Node_Id := Original_Node (Node2);
-- We do the tests on original nodes, since we are most interested
-- in the original source, not any expansion that got in the way.
K1 : constant Node_Kind := Nkind (N1);
K2 : constant Node_Kind := Nkind (N2);
begin
-- First case, both are entities with same entity
if K1 in N_Has_Entity
and then K2 in N_Has_Entity
and then Present (Entity (N1))
and then Present (Entity (N2))
and then (Ekind (Entity (N1)) = E_Variable
or else
Ekind (Entity (N1)) = E_Constant)
and then Entity (N1) = Entity (N2)
then
return True;
-- Second case, selected component with same selector, same record
elsif K1 = N_Selected_Component
and then K2 = N_Selected_Component
and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
then
return Same_Object (Prefix (N1), Prefix (N2));
-- Third case, indexed component with same subscripts, same array
elsif K1 = N_Indexed_Component
and then K2 = N_Indexed_Component
and then Same_Object (Prefix (N1), Prefix (N2))
then
declare
E1, E2 : Node_Id;
begin
E1 := First (Expressions (N1));
E2 := First (Expressions (N2));
while Present (E1) loop
if not Same_Value (E1, E2) then
return False;
else
Next (E1);
Next (E2);
end if;
end loop;
return True;
end;
-- Fourth case, slice of same array with same bounds
elsif K1 = N_Slice
and then K2 = N_Slice
and then Nkind (Discrete_Range (N1)) = N_Range
and then Nkind (Discrete_Range (N2)) = N_Range
and then Same_Value (Low_Bound (Discrete_Range (N1)),
Low_Bound (Discrete_Range (N2)))
and then Same_Value (High_Bound (Discrete_Range (N1)),
High_Bound (Discrete_Range (N2)))
then
return Same_Name (Prefix (N1), Prefix (N2));
-- All other cases, not clearly the same object
else
return False;
end if;
end Same_Object;
--------------- ---------------
-- Same_Type -- -- Same_Type --
--------------- ---------------
@ -8251,6 +8539,24 @@ package body Sem_Util is
end if; end if;
end Same_Type; end Same_Type;
----------------
-- Same_Value --
----------------
function Same_Value (Node1, Node2 : Node_Id) return Boolean is
begin
if Compile_Time_Known_Value (Node1)
and then Compile_Time_Known_Value (Node2)
and then Expr_Value (Node1) = Expr_Value (Node2)
then
return True;
elsif Same_Object (Node1, Node2) then
return True;
else
return False;
end if;
end Same_Value;
------------------------ ------------------------
-- Scope_Is_Transient -- -- Scope_Is_Transient --
------------------------ ------------------------
@ -8886,7 +9192,6 @@ package body Sem_Util is
-- There is no simple way to insure that it is consistent ??? -- There is no simple way to insure that it is consistent ???
elsif In_Instance then elsif In_Instance then
if Etype (Etype (Expr)) = Etype (Expected_Type) if Etype (Etype (Expr)) = Etype (Expected_Type)
and then and then
(Has_Private_Declaration (Expected_Type) (Has_Private_Declaration (Expected_Type)
@ -8924,6 +9229,29 @@ package body Sem_Util is
Error_Msg_N ("result must be general access type!", Expr); Error_Msg_N ("result must be general access type!", Expr);
Error_Msg_NE ("add ALL to }!", Expr, Expec_Type); Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
-- Another special check, if the expected type is an integer type,
-- but the expression is of type System.Address, and the parent is
-- an addition or subtraction operation whose left operand is the
-- expression in question and whose right operand is of an integral
-- type, then this is an attempt at address arithmetic, so give
-- appropriate message.
elsif Is_Integer_Type (Expec_Type)
and then Is_RTE (Found_Type, RE_Address)
and then (Nkind (Parent (Expr)) = N_Op_Add
or else
Nkind (Parent (Expr)) = N_Op_Subtract)
and then Expr = Left_Opnd (Parent (Expr))
and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
then
Error_Msg_N
("address arithmetic not predefined in package System",
Parent (Expr));
Error_Msg_N
("\possible missing with/use of System.Storage_Elements",
Parent (Expr));
return;
-- If the expected type is an anonymous access type, as for access -- If the expected type is an anonymous access type, as for access
-- parameters and discriminants, the error is on the designated types. -- parameters and discriminants, the error is on the designated types.

95
gcc/ada/sem_util.ads
View File

@ -28,6 +28,7 @@
with Einfo; use Einfo; with Einfo; use Einfo;
with Namet; use Namet; with Namet; use Namet;
with Nmake;
with Types; use Types; with Types; use Types;
with Uintp; use Uintp; with Uintp; use Uintp;
with Urealp; use Urealp; with Urealp; use Urealp;
@ -147,10 +148,13 @@ package Sem_Util is
procedure Collect_Abstract_Interfaces procedure Collect_Abstract_Interfaces
(T : Entity_Id; (T : Entity_Id;
Ifaces_List : out Elist_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 -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are
-- directly or indirectly implemented by T. Exclude_Parent_Interfaces is -- directly or indirectly implemented by T. Exclude_Parent_Interfaces is
-- used to avoid addition of inherited interfaces to the generated list. -- 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 procedure Collect_Interface_Components
(Tagged_Type : Entity_Id; (Tagged_Type : Entity_Id;
@ -158,6 +162,17 @@ package Sem_Util is
-- Ada 2005 (AI-251): Collect all the tag components associated with the -- Ada 2005 (AI-251): Collect all the tag components associated with the
-- secondary dispatch tables of a tagged type. -- 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; function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id;
-- Called upon type derivation and extension. We scan the declarative -- Called upon type derivation and extension. We scan the declarative
-- part in which the type appears, and collect subprograms that have -- part in which the type appears, and collect subprograms that have
@ -282,7 +297,7 @@ package Sem_Util is
(Def_Id : Entity_Id; (Def_Id : Entity_Id;
First_Hom : Entity_Id; First_Hom : Entity_Id;
Ifaces_List : Elist_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 -- Determine whether entry or subprogram Def_Id overrides a primitive
-- operation that belongs to one of the interfaces in Ifaces_List. A -- operation that belongs to one of the interfaces in Ifaces_List. A
-- specific homonym chain can be specified by setting First_Hom. Flag -- 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 -- Result of Has_Compatible_Alignment test, description found below. Note
-- that the values are arranged in increasing order of problematicness. -- that the values are arranged in increasing order of problematicness.
function Has_Abstract_Interfaces (Tagged_Type : Entity_Id) return Boolean; function Has_Abstract_Interfaces
-- Returns true if Tagged_Type implements some abstract interface (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 function Has_Compatible_Alignment
(Obj : Entity_Id; (Obj : Entity_Id;
@ -689,6 +708,9 @@ package Sem_Util is
-- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo).
-- Note that a label is *not* a statement, and will return False. -- 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; function Is_Transfer (N : Node_Id) return Boolean;
-- Returns True if the node N is a statement which is known to cause -- 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 -- an unconditional transfer of control at runtime, i.e. the following
@ -723,17 +745,16 @@ package Sem_Util is
procedure Kill_Current_Values; procedure Kill_Current_Values;
-- This procedure is called to clear all constant indications from all -- This procedure is called to clear all constant indications from all
-- entities in the current scope and in any parent scopes if the current -- 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 -- scope is a block or a package (and that recursion continues to the top
-- top scope that is not a block or a package). This is used when the -- scope that is not a block or a package). This is used when the
-- sequential flow-of-control assumption is violated (occurence of a -- sequential flow-of-control assumption is violated (occurence of a label,
-- label, head of a loop, or start of an exception handler). The effect -- head of a loop, or start of an exception handler). The effect of the
-- of the call is to clear the Constant_Value field (but we do not need -- call is to clear the Constant_Value field (but we do not need to clear
-- to clear the Is_True_Constant flag, since that only gets reset if -- the Is_True_Constant flag, since that only gets reset if there really is
-- there really is an assignment somewhere in the entity scope). This -- an assignment somewhere in the entity scope). This procedure also calls
-- procedure also calls Kill_All_Checks, since this is a special case -- Kill_All_Checks, since this is a special case of needing to forget saved
-- of needing to forget saved values. This procedure also clears any -- values. This procedure also clears Is_Known_Non_Null flags in variables,
-- Is_Known_Non_Null flags in variables, constants or parameters -- constants or parameters since these are also not known to be valid.
-- since these are also not known to be valid.
procedure Kill_Current_Values (Ent : Entity_Id); procedure Kill_Current_Values (Ent : Entity_Id);
-- This performs the same processing as described above for the form with -- 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 -- 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. -- be may return True from May_Be_Lvalue, but False from this function.
procedure Mark_Static_Coextensions (Root_Node : Node_Id); function Make_Simple_Return_Statement
-- Perform a tree traversal starting from Root_Node while marking every (Sloc : Source_Ptr;
-- allocator as a static coextension. Cleanup for this action is performed Expression : Node_Id := Empty) return Node_Id
-- in Resolve_Allocator. 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; function May_Be_Lvalue (N : Node_Id) return Boolean;
-- Determines if N could be an lvalue (e.g. an assignment left hand side). -- 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. -- capture actual value information, but we can capture conditional tests.
function Same_Name (N1, N2 : Node_Id) return Boolean; 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; function Same_Type (T1, T2 : Entity_Id) return Boolean;
-- Determines if T1 and T2 represent exactly the same type. Two types -- 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 -- False is indecisive (e.g. the compiler may not be able to tell that
-- two constraints are identical). -- 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; 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 -- Determines if the entity Scope1 is the same as Scope2, or if it is
-- inside it, where both entities represent scopes. Note that scopes -- 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 -- 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. -- 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 -- True if the current scope is transient
function Static_Integer (N : Node_Id) return Uint; function Static_Integer (N : Node_Id) return Uint;