diff options
author | Steve Baird <baird@adacore.com> | 2021-08-02 16:18:08 -0700 |
---|---|---|
committer | Pierre-Marie de Rodat <derodat@adacore.com> | 2021-10-01 06:13:36 +0000 |
commit | aa4648eef474d7827b9ccf948ad4de128783e171 (patch) | |
tree | 73385a605f8ed74946f949e50943ca214a414422 | |
parent | a6fe12b0a9a375e655945ff385810661d8bb494c (diff) | |
download | gcc-aa4648eef474d7827b9ccf948ad4de128783e171.zip gcc-aa4648eef474d7827b9ccf948ad4de128783e171.tar.gz gcc-aa4648eef474d7827b9ccf948ad4de128783e171.tar.bz2 |
[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.
-rw-r--r-- | gcc/ada/sem_res.adb | 35 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 73 | ||||
-rw-r--r-- | 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 12b3295..7b9f8ab 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 de18f75..816fb45 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 79db0b4..4e896a35 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 |