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

[Ada] Additional warnings on overlapping actuals of composite types 

2020-06-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* sem_warn.adb (Warn_On_Overlapping_Actuals): Simplify code,
	remove inner predicate Is_Covered_Formal, preserve warning for
	two overlapping composite types when only one is writable, and
	for two overlapping and writable elementary types.
This commit is contained in:
Ed Schonberg 2020-03-16 11:25:14 -04:00 committed by Pierre-Marie de Rodat
parent 4127ebece7
commit eb85899d60
1 changed files with 138 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
gcc/ada/sem_warn.adb
View File

@ -3643,9 +3643,6 @@ package body Sem_Warn is
--------------------------------- ---------------------------------
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
function Is_Covered_Formal (Formal : Node_Id) return Boolean;
-- Return True if Formal is covered by the rule
function Refer_Same_Object function Refer_Same_Object
(Act1 : Node_Id; (Act1 : Node_Id;
Act2 : Node_Id) return Boolean; Act2 : Node_Id) return Boolean;
@ -3657,19 +3654,6 @@ package body Sem_Warn is
-- object_name is known to refer to the same object as the other name -- object_name is known to refer to the same object as the other name
-- (RM 6.4.1(6.11/3)) -- (RM 6.4.1(6.11/3))
-----------------------
-- Is_Covered_Formal --
-----------------------
function Is_Covered_Formal (Formal : Node_Id) return Boolean is
begin
return
Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter)
and then (Is_Elementary_Type (Etype (Formal))
or else Is_Record_Type (Etype (Formal))
or else Is_Array_Type (Etype (Formal)));
end Is_Covered_Formal;
----------------------- -----------------------
-- Refer_Same_Object -- -- Refer_Same_Object --
----------------------- -----------------------
@ -3759,137 +3743,182 @@ package body Sem_Warn is
Form1 := First_Formal (Subp); Form1 := First_Formal (Subp);
Act1 := First_Actual (N); Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop while Present (Form1) and then Present (Act1) loop
if Is_Covered_Formal (Form1) if Is_Generic_Type (Etype (Act1)) then
or else not Is_Elementary_Type (Etype (Act1)) return;
end if;
-- One of the formals must be either (in)-out or composite.
-- The other must be (in)-out.
if Is_Elementary_Type (Etype (Act1))
and then Ekind (Form1) = E_In_Parameter
then then
null;
else
Form2 := First_Formal (Subp); Form2 := First_Formal (Subp);
Act2 := First_Actual (N); Act2 := First_Actual (N);
while Present (Form2) and then Present (Act2) loop while Present (Form2) and then Present (Act2) loop
if Form1 /= Form2 if Form1 /= Form2
and then Is_Covered_Formal (Form2)
and then Refer_Same_Object (Act1, Act2) and then Refer_Same_Object (Act1, Act2)
then then
if Is_Generic_Type (Etype (Act2)) then
return;
end if;
-- First case : two writable elementary parameters
-- that overlap.
if (Is_Elementary_Type (Etype (Form1))
and then Is_Elementary_Type (Etype (Form2))
and then Ekind (Form1) /= E_In_Parameter
and then Ekind (Form2) /= E_In_Parameter)
-- Second case : two composite parameters that overlap,
-- one of which is writable.
or else (Is_Composite_Type (Etype (Form1))
and then Is_Composite_Type (Etype (Form2))
and then (Ekind (Form1) /= E_In_Parameter
or else Ekind (Form2) /= E_In_Parameter))
-- Third case : an elementary writable parameter that
-- overlaps a composite one.
or else (Is_Elementary_Type (Etype (Form1))
and then Ekind (Form1) /= E_In_Parameter
and then Is_Composite_Type (Etype (Form2)))
or else (Is_Elementary_Type (Etype (Form2))
and then Ekind (Form2) /= E_In_Parameter
and then Is_Composite_Type (Etype (Form1)))
then
-- Guard against previous errors -- Guard against previous errors
if Error_Posted (N) if Error_Posted (N)
or else No (Etype (Act1)) or else No (Etype (Act1))
or else No (Etype (Act2)) or else No (Etype (Act2))
then then
null; null;
-- If the actual is a function call in prefix notation, -- If the actual is a function call in prefix notation,
-- there is no real overlap. -- there is no real overlap.
elsif Nkind (Act2) = N_Function_Call then elsif Nkind (Act2) = N_Function_Call then
null; null;
-- If type is not by-copy, assume that aliasing is intended -- If type is explicitly not by-copy, assume that
-- aliasing is intended.
elsif elsif
Present (Underlying_Type (Etype (Form1))) Present (Underlying_Type (Etype (Form1)))
and then and then
(Is_By_Reference_Type (Underlying_Type (Etype (Form1))) (Is_By_Reference_Type
or else (Underlying_Type (Etype (Form1)))
Convention (Underlying_Type (Etype (Form1))) = or else
Convention_Ada_Pass_By_Reference) Convention (Underlying_Type (Etype (Form1))) =
then Convention_Ada_Pass_By_Reference)
null; then
null;
-- Under Ada 2012 we only report warnings on overlapping -- Under Ada 2012 we only report warnings on overlapping
-- arrays and record types if switch is set. -- arrays and record types if switch is set.
elsif Ada_Version >= Ada_2012 elsif Ada_Version >= Ada_2012
and then not Is_Elementary_Type (Etype (Form1)) and then not Is_Elementary_Type (Etype (Form1))
and then not Warn_On_Overlap and then not Warn_On_Overlap
then then
null; null;
-- Here we may need to issue overlap message -- Here we may need to issue overlap message
else else
Error_Msg_Warn := Error_Msg_Warn :=
-- Overlap checking is an error only in Ada 2012. For -- Overlap checking is an error only in Ada 2012.
-- earlier versions of Ada, this is a warning. -- For earlier versions of Ada, this is a warning.
Ada_Version < Ada_2012 Ada_Version < Ada_2012
-- Overlap is only illegal in Ada 2012 in the case of -- Overlap is only illegal in Ada 2012 in the case
-- elementary types (passed by copy). For other types, -- of elementary types (passed by copy). For other
-- we always have a warning in all Ada versions. -- types we always have a warning in all versions.
or else not Is_Elementary_Type (Etype (Form1)) or else not Is_Elementary_Type (Etype (Form1))
-- debug flag -gnatd.E changes the error to a warning -- debug flag -gnatd.E changes the error to a
-- even in Ada 2012 mode. -- warning even in Ada 2012 mode.
or else Error_To_Warning or else Error_To_Warning
or else Warn_Only; or else Warn_Only;
declare declare
Act : Node_Id; Act : Node_Id;
Form : Entity_Id; Form : Entity_Id;
begin begin
-- Find matching actual -- Find matching actual
Act := First_Actual (N); Act := First_Actual (N);
Form := First_Formal (Subp); Form := First_Formal (Subp);
while Act /= Act2 loop while Act /= Act2 loop
Next_Formal (Form); Next_Formal (Form);
Next_Actual (Act); Next_Actual (Act);
end loop; end loop;
if Is_Elementary_Type (Etype (Act1)) if Is_Elementary_Type (Etype (Act1))
and then Ekind (Form2) = E_In_Parameter and then Ekind (Form2) = E_In_Parameter
then then
null; -- No real aliasing null; -- No real aliasing
elsif Is_Elementary_Type (Etype (Act2)) elsif Is_Elementary_Type (Etype (Act2))
and then Ekind (Form2) = E_In_Parameter and then Ekind (Form2) = E_In_Parameter
then then
null; -- Ditto null; -- Ditto
-- If the call was written in prefix notation, and -- If the call was written in prefix notation, and
-- thus its prefix before rewriting was a selected -- thus its prefix before rewriting was a selected
-- component, count only visible actuals in the call. -- component, count only visible actuals in call.
elsif Is_Entity_Name (First_Actual (N)) elsif Is_Entity_Name (First_Actual (N))
and then Nkind (Original_Node (N)) = Nkind (N) and then Nkind (Original_Node (N)) = Nkind (N)
and then Nkind (Name (Original_Node (N))) = and then Nkind (Name (Original_Node (N))) =
N_Selected_Component N_Selected_Component
and then and then
Is_Entity_Name (Prefix (Name (Original_Node (N)))) Is_Entity_Name
and then (Prefix (Name (Original_Node (N))))
Entity (Prefix (Name (Original_Node (N)))) = and then
Entity (First_Actual (N)) Entity (Prefix (Name (Original_Node (N)))) =
then Entity (First_Actual (N))
if Act1 = First_Actual (N) then then
Error_Msg_FE if Act1 = First_Actual (N) then
("<<`IN OUT` prefix overlaps with " Error_Msg_FE
& "actual for&", Act1, Form); ("<<`IN OUT` prefix overlaps with "
& "actual for&", Act1, Form);
else
-- For greater clarity, give name of formal
Error_Msg_Node_2 := Form;
Error_Msg_FE
("<<writable actual for & overlaps with "
& "actual for&", Act1, Form);
end if;
else else
-- For greater clarity, give name of formal -- For greater clarity, give name of formal
Error_Msg_Node_2 := Form; Error_Msg_Node_2 := Form;
-- This is one of the messages
Error_Msg_FE Error_Msg_FE
("<<writable actual for & overlaps with " ("<<writable actual for & overlaps with "
& "actual for&", Act1, Form); & "actual for&", Act1, Form1);
end if; end if;
end;
else end if;
-- For greater clarity, give name of formal
Error_Msg_Node_2 := Form;
-- This is one of the messages
Error_Msg_FE
("<<writable actual for & overlaps with "
& "actual for&", Act1, Form1);
end if;
end;
end if; end if;
return; return;