From aa4648eef474d7827b9ccf948ad4de128783e171 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Mon, 2 Aug 2021 16:18:08 -0700 Subject: [PATCH] [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. --- 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 12b32956146a..7b9f8ab48d8e 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 de18f75f0215..816fb451fd0c 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 79db0b47c144..4e896a3599f1 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 -- 2.47.2