[gcc r12-4011] [Ada] Fix bug in inherited user-defined-literal aspects for tagged types
Pierre-Marie de Rodat
pmderodat@gcc.gnu.org
Fri Oct 1 06:15:01 GMT 2021
https://gcc.gnu.org/g:aa4648eef474d7827b9ccf948ad4de128783e171
commit r12-4011-gaa4648eef474d7827b9ccf948ad4de128783e171
Author: Steve Baird <baird@adacore.com>
Date: Mon Aug 2 16:18:08 2021 -0700
[Ada] Fix bug in inherited user-defined-literal aspects for tagged types
gcc/ada/
* sem_res.adb (Resolve): Two separate fixes. In the case where
Find_Aspect for a literal aspect returns the aspect for a
different (ancestor) type, call Corresponding_Primitive_Op to
get the right callee. In the case where a downward tagged type
conversion appears to be needed, generate a null extension
aggregate instead, as per Ada RM 3.4(27).
* sem_util.ads, sem_util.adb: Add new Corresponding_Primitive_Op
function. It maps a primitive op of a tagged type and a
descendant type of that tagged type to the corresponding
primitive op of the descendant type. The body of this function
was written by Javier Miranda.
Diff:
---
gcc/ada/sem_res.adb | 35 ++++++++++++++++++-------
gcc/ada/sem_util.adb | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_util.ads | 7 +++++
3 files changed, 106 insertions(+), 9 deletions(-)
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 12b32956146..7b9f8ab48d8 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -2920,6 +2920,16 @@ package body Sem_Res is
Expr : Node_Id;
begin
+ if Is_Derived_Type (Typ)
+ and then Is_Tagged_Type (Typ)
+ and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
+ then
+ Callee :=
+ Corresponding_Primitive_Op
+ (Ancestor_Op => Callee,
+ Descendant_Type => Base_Type (Typ));
+ end if;
+
if Nkind (N) = N_Identifier then
Expr := Expression (Declaration_Node (Entity (N)));
@@ -2990,16 +3000,23 @@ package body Sem_Res is
Set_Etype (Call, Etype (Callee));
- -- Conversion needed in case of an inherited aspect
- -- of a derived type.
- --
- -- ??? Need to do something different here for downward
- -- tagged conversion case (which is only possible in the
- -- case of a null extension); the current call to
- -- Convert_To results in an error message about an illegal
- -- downward conversion.
+ if Base_Type (Etype (Call)) /= Base_Type (Typ) then
+ -- Conversion may be needed in case of an inherited
+ -- aspect of a derived type. For a null extension, we
+ -- use a null extension aggregate instead because the
+ -- downward type conversion would be illegal.
- Call := Convert_To (Typ, Call);
+ if Is_Null_Extension_Of
+ (Descendant => Typ,
+ Ancestor => Etype (Call))
+ then
+ Call := Make_Extension_Aggregate (Loc,
+ Ancestor_Part => Call,
+ Null_Record_Present => True);
+ else
+ Call := Convert_To (Typ, Call);
+ end if;
+ end if;
Rewrite (N, Call);
end;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index de18f75f021..816fb451fd0 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7073,6 +7073,79 @@ package body Sem_Util is
end if;
end Corresponding_Generic_Type;
+ --------------------------------
+ -- Corresponding_Primitive_Op --
+ --------------------------------
+
+ function Corresponding_Primitive_Op
+ (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;
+ Prim : Entity_Id;
+ begin
+ pragma Assert (Is_Dispatching_Operation (Ancestor_Op));
+ pragma Assert (Is_Ancestor (Typ, Descendant_Type)
+ or else Is_Progenitor (Typ, Descendant_Type));
+
+ Elmt := First_Elmt (Primitive_Operations (Descendant_Type));
+
+ while Present (Elmt) loop
+ Subp := Node (Elmt);
+
+ -- For regular primitives we only need to traverse the chain of
+ -- ancestors when the name matches the name of Ancestor_Op, but
+ -- for predefined dispatching operations we cannot rely on the
+ -- name of the primitive to identify a candidate since their name
+ -- is internally built adding a suffix to the name of the tagged
+ -- type.
+
+ if Chars (Subp) = Chars (Ancestor_Op)
+ or else Is_Predefined_Dispatching_Operation (Subp)
+ then
+ -- Handle case where Ancestor_Op is a primitive of a progenitor.
+ -- We rely on internal entities that map interface primitives:
+ -- their attribute Interface_Alias references the interface
+ -- primitive, and their Alias attribute references the primitive
+ -- of Descendant_Type implementing that interface primitive.
+
+ if Present (Interface_Alias (Subp)) then
+ if Interface_Alias (Subp) = Ancestor_Op then
+ return Alias (Subp);
+ end if;
+
+ -- Traverse the chain of ancestors searching for Ancestor_Op.
+ -- Overridden primitives have attribute Overridden_Operation;
+ -- inherited primitives have attribute Alias.
+
+ else
+ Prim := Subp;
+
+ while Present (Overridden_Operation (Prim))
+ or else Present (Alias (Prim))
+ loop
+ if Present (Overridden_Operation (Prim)) then
+ Prim := Overridden_Operation (Prim);
+ else
+ Prim := Alias (Prim);
+ end if;
+
+ if Prim = Ancestor_Op then
+ return Subp;
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ pragma Assert (False);
+ return Empty;
+ end Corresponding_Primitive_Op;
+
--------------------
-- Current_Entity --
--------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 79db0b47c14..4e896a3599f 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -638,6 +638,13 @@ package Sem_Util is
-- attribute, except in the case of formal private and derived types.
-- 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)
+ -- descendant type of that type, find the corresponding primitive
+ -- subprogram of the descendant type.
+
function Current_Entity (N : Node_Id) return Entity_Id;
pragma Inline (Current_Entity);
-- Find the currently visible definition for a given identifier, that is to
More information about the Gcc-cvs
mailing list