Commit 0715a2a8 by Hristian Kirtchev Committed by Pierre-Marie de Rodat

[Ada] Renamed equality leads to spurious errors

The following patch corrects the search for the equality function to
handle cases where the equality could be a renaming of another routine.
No simple reproducer possible because this requires PolyORB.

2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_ch4.adb (Find_Aliased_Equality): New routine.
	(Find_Equality): Reimplemented.
	(Is_Equality): New routine.

From-SVN: r266121
parent b3b3ada9
2018-11-14 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Find_Aliased_Equality): New routine.
(Find_Equality): Reimplemented.
(Is_Equality): New routine.
2018-11-14 Hristian Kirtchev <kirtchev@adacore.com>
* ghost.adb (Ghost_Entity): New routine.
(Mark_And_Set_Ghost_Assignment): Reimplemented.
* sem_ch5.adb (Analyze_Assignment): Assess whether the target of
......
......@@ -7560,57 +7560,96 @@ package body Exp_Ch4 is
-------------------
function Find_Equality (Prims : Elist_Id) return Entity_Id is
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id;
-- Find an equality in a possible alias chain starting from primitive
-- operation Prim.
begin
-- Assume that the tagged type lacks an equality
function Is_Equality (Id : Entity_Id) return Boolean;
-- Determine whether arbitrary entity Id denotes an equality
Prim := Empty;
---------------------------
-- Find_Aliased_Equality --
---------------------------
-- Inspect the list of primitives looking for a suitable equality
function Find_Aliased_Equality (Prim : Entity_Id) return Entity_Id is
Candid : Entity_Id;
Prim_Elmt := First_Elmt (Prims);
while Present (Prim_Elmt) loop
begin
-- Inspect each candidate in the alias chain, checking whether it
-- denotes an equality.
-- Traverse a potential chain of derivations to recover the parent
-- equality.
Candid := Prim;
while Present (Candid) loop
if Is_Equality (Candid) then
return Candid;
end if;
Prim := Ultimate_Alias (Node (Prim_Elmt));
Candid := Alias (Candid);
end loop;
-- The current primitives denotes function "=" that returns a
-- Boolean. This could be the suitable equality if the formal
-- parameters agree.
return Empty;
end Find_Aliased_Equality;
if Ekind (Prim) = E_Function
and then Chars (Prim) = Name_Op_Eq
and then Base_Type (Etype (Prim)) = Standard_Boolean
-----------------
-- Is_Equality --
-----------------
function Is_Equality (Id : Entity_Id) return Boolean is
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
begin
-- The equality function carries name "=", returns Boolean, and
-- has exactly two formal parameters of an identical type.
if Ekind (Id) = E_Function
and then Chars (Id) = Name_Op_Eq
and then Base_Type (Etype (Id)) = Standard_Boolean
then
Formal_1 := First_Formal (Prim);
Formal_1 := First_Formal (Id);
Formal_2 := Empty;
if Present (Formal_1) then
Formal_2 := Next_Formal (Formal_1);
end if;
if Present (Formal_1)
and then Present (Formal_2)
and then Etype (Formal_1) = Etype (Formal_2)
then
exit;
end if;
return
Present (Formal_1)
and then Present (Formal_2)
and then Etype (Formal_1) = Etype (Formal_2)
and then No (Next_Formal (Formal_2));
end if;
return False;
end Is_Equality;
-- Local variables
Eq_Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
-- Start of processing for Find_Equality
begin
-- Assume that the tagged type lacks an equality
Eq_Prim := Empty;
-- Inspect the list of primitives looking for a suitable equality
-- within a possible chain of aliases.
Prim_Elmt := First_Elmt (Prims);
while Present (Prim_Elmt) and then No (Eq_Prim) loop
Eq_Prim := Find_Aliased_Equality (Node (Prim_Elmt));
Next_Elmt (Prim_Elmt);
end loop;
-- A tagged type should have an equality in its list of primitives
-- A tagged type should always have an equality
pragma Assert (Present (Prim));
pragma Assert (Present (Eq_Prim));
return Prim;
return Eq_Prim;
end Find_Equality;
------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment