In some cases, an integer literal of a tagged type whose Integer_Literal
aspect is inherited from an ancestor type was not handled correctly by
the compiler. In particular, Ada RM 13.1(15.5) was not correctly
implemented, resulting in the incorrect rejection of legal uses of
integer literals with (incorrect) semantic error messages about illegal
downward conversions. The same problem also affected the other two
user-defined literal aspects, Real_Literal and String_Literal. These
bugs are corrected.
Tested on x86_64-pc-linux-gnu, committed on trunk
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 --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- 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
--- 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
--- 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
