[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 --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 12b32956146a02a87085316d1a06f840b55e5d82..7b9f8ab48d8ee32648b9113f7fb3d7ef008153f7 100644 (file)
--- 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 de18f75f0215bff6c9a794a95042a21ed7a027b1..816fb451fd0cf1349978dc69ce08b2e73443a982 100644 (file)
--- 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 79db0b47c144864bf79d4d4ae331a7800b71c278..4e896a3599f15cde42ec0a1e05c563418b6b477a 100644 (file)
--- 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