From: Eric Botcazou <[email protected]>
We accept overloading for the primitives denoted by the Finalizable aspect,
so Find_Controlled_Prim_Op needs to filter out the unrelated primitives.
gcc/ada/ChangeLog:
* exp_util.ads (Find_Optional_Prim_Op): Add Controlled_Op parameter
defaulting to False.
* exp_util.adb (Find_Optional_Prim_Op): Likewise. When it is set to
True, test whether the primitive has the signature of the controlled
primitives.
* sem_ch13.adb (Resolve_Finalization_Procedure): Reset Is_Overloaded
once an interpretation has been selected among the set.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_util.adb | 25 ++++++++++++++++++-------
gcc/ada/exp_util.ads | 8 +++++++-
gcc/ada/sem_ch13.adb | 1 +
3 files changed, 26 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 7a19c6c1d04..f4bcd18dab7 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6393,7 +6393,7 @@ package body Exp_Util is
return Empty;
end if;
- return Find_Optional_Prim_Op (T, Op_Name);
+ return Find_Optional_Prim_Op (T, Op_Name, Controlled_Op => True);
end Find_Controlled_Prim_Op;
------------------------
@@ -7047,11 +7047,13 @@ package body Exp_Util is
---------------------------
function Find_Optional_Prim_Op
- (T : Entity_Id; Name : Name_Id) return Entity_Id
+ (T : Entity_Id;
+ Name : Name_Id;
+ Controlled_Op : Boolean := False) return Entity_Id
is
+ Op : Entity_Id;
Prim : Elmt_Id;
Typ : Entity_Id := T;
- Op : Entity_Id;
begin
if Is_Class_Wide_Type (Typ) then
@@ -7073,14 +7075,23 @@ package body Exp_Util is
Op := Node (Prim);
-- We can retrieve primitive operations by name if it is an internal
- -- name. For equality we must check that both of its operands have
- -- the same type, to avoid confusion with user-defined equalities
- -- than may have a asymmetric signature.
+ -- name. For equality, we must check that both of its operands have
+ -- the same type, to avoid confusion with user-defined equalities,
+ -- which may have an asymmetric signature. For controlled operations,
+ -- we check that the primitive is a procedure with a single In Out
+ -- parameter of a non-access type.
exit when Chars (Op) = Name
and then
(Name /= Name_Op_Eq
- or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
+ or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)))
+ and then
+ (not Controlled_Op
+ or else
+ (Ekind (Op) = E_Procedure
+ and then Ekind (First_Formal (Op)) = E_In_Out_Parameter
+ and then not Is_Access_Type (Etype (First_Formal (Op)))
+ and then No (Next_Formal (First_Formal (Op)))));
Next_Elmt (Prim);
end loop;
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index f8118b76424..91f5ec85f0a 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -672,7 +672,13 @@ package Exp_Util is
-- although they are not master constructs in the language.
function Find_Optional_Prim_Op
- (T : Entity_Id; Name : Name_Id) return Entity_Id;
+ (T : Entity_Id;
+ Name : Name_Id;
+ Controlled_Op : Boolean := False) return Entity_Id;
+ -- Same as Find_Prim_Op but, if Controlled_Op is True, returns a primitive
+ -- only if it has the signature of the three primitives of controlled types
+ -- Initialize/Adjust/Finalize, and returns Empty if not found.
+
function Find_Optional_Prim_Op
(T : Entity_Id;
Name : TSS_Name_Type) return Entity_Id;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index e2be2592870..b2845814d30 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -18013,6 +18013,7 @@ package body Sem_Ch13 is
while Present (It.Typ) loop
if Is_Finalizable_Primitive (It.Nam) then
Set_Entity (N, It.Nam);
+ Set_Is_Overloaded (N, False);
return True;
end if;
--
2.53.0
