From: Eric Botcazou <ebotca...@adacore.com>
In Ada 2022, user-defined literal aspects are nonoverridable but the named
subprograms present in them can be overridden, including for untagged types.
gcc/ada/
* sem_res.adb (Has_Applicable_User_Defined_Literal): Apply the
same processing for derived untagged types as for tagged types.
* sem_util.ads (Corresponding_Primitive_Op): Adjust description.
* sem_util.adb (Corresponding_Primitive_Op): Handle untagged
types.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_res.adb | 1 -
gcc/ada/sem_util.adb | 39 +++++++++++++++++++++++++++++++++++----
gcc/ada/sem_util.ads | 6 +++---
3 files changed, 38 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index df9ccb18468..f6634da42a7 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -492,7 +492,6 @@ package body Sem_Res is
Name := Make_Identifier (Loc, Chars (Callee));
if Is_Derived_Type (Typ)
- and then Is_Tagged_Type (Typ)
and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
then
Callee :=
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 38dc654f7be..1d8d4fc30f8 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6483,9 +6483,8 @@ package body Sem_Util is
(Ancestor_Op : Entity_Id;
Descendant_Type : Entity_Id) return Entity_Id
is
- Typ : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op);
- Elmt : Elmt_Id;
- Subp : Entity_Id;
+ function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id;
+ -- Search for the untagged type of the primitive operation Prim.
function Profile_Matches_Ancestor (S : Entity_Id) return Boolean;
-- Returns True if subprogram S has the proper profile for an
@@ -6493,6 +6492,34 @@ package body Sem_Util is
-- have the same type, or are corresponding controlling formals,
-- and similarly for result types).
+ ---------------------------
+ -- Find_Untagged_Type_Of --
+ ---------------------------
+
+ function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := First_Entity (Scope (Prim));
+
+ begin
+ while Present (E) and then E /= Prim loop
+ if not Is_Tagged_Type (E)
+ and then Present (Direct_Primitive_Operations (E))
+ and then Contains (Direct_Primitive_Operations (E), Prim)
+ then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ pragma Assert (False);
+ return Empty;
+ end Find_Untagged_Type_Of;
+
+ Typ : constant Entity_Id :=
+ (if Is_Dispatching_Operation (Ancestor_Op)
+ then Find_Dispatching_Type (Ancestor_Op)
+ else Find_Untagged_Type_Of (Ancestor_Op));
+
------------------------------
-- Profile_Matches_Ancestor --
------------------------------
@@ -6529,10 +6556,14 @@ package body Sem_Util is
or else Is_Ancestor (Typ, Etype (S)));
end Profile_Matches_Ancestor;
+ -- Local variables
+
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
-- Start of processing for Corresponding_Primitive_Op
begin
- pragma Assert (Is_Dispatching_Operation (Ancestor_Op));
pragma Assert (Is_Ancestor (Typ, Descendant_Type)
or else Is_Progenitor (Typ, Descendant_Type));
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index f98e05615fd..42c6d249e2f 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -618,9 +618,9 @@ package Sem_Util is
-- Possible optimization???
function Corresponding_Primitive_Op
- (Ancestor_Op : Entity_Id;
- Descendant_Type : Entity_Id) return Entity_Id;
- -- Given a primitive subprogram of a tagged type and a (distinct)
+ (Ancestor_Op : Entity_Id;
+ Descendant_Type : Entity_Id) return Entity_Id;
+ -- Given a primitive subprogram of a first type and a (distinct)
-- descendant type of that type, find the corresponding primitive
-- subprogram of the descendant type.
--
2.40.0
