ada: Use static references to tag in more cases for interface objects

This extends the use of static references to the interface tag in more cases
for (class-wide) interface objects, e.g. for initialization expressions that
are qualified aggregates or nondispatching calls returning a specific tagged
type implementing the interface.

gcc/ada/

	* exp_util.ads (Has_Tag_Of_Type): Declare.
	* exp_util.adb (Has_Tag_Of_Type): Move to package level.  Recurse on
	qualified expressions.
	* exp_ch3.adb (Expand_N_Object_Declaration): Use a static reference
	to the interface tag in more cases for class-wide interface objects.

3 files changed, 95 insertions, 93 deletions

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index bbb53fc6e49..6bc76aec5d1 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -7564,7 +7564,7 @@ package body Exp_Ch3 is
                Expr_Q := Expr;
             end if;
 
-            --  We may use a renaming if the initializing expression is a
+            --  We may use a renaming if the initialization expression is a
             --  captured function call that meets a few conditions.
 
             Rewrite_As_Renaming := Is_Renamable_Function_Call (Expr_Q);
@@ -7622,41 +7622,6 @@ package body Exp_Ch3 is
                   Obj_Id := Make_Temporary (Loc, 'D', Expr_Q);
 
                   --  Replace
-                  --     CW : I'Class := Obj;
-                  --  by
-                  --     Dnn : Typ := Obj;
-                  --     type Ityp is not null access I'Class;
-                  --     Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
-                  --     CW  : I'Class renames Rnn.all;
-
-                  if Comes_From_Source (Expr_Q)
-                    and then Is_Entity_Name (Expr_Q)
-                    and then not Is_Interface (Expr_Typ)
-                    and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
-                    and then (Expr_Typ = Etype (Expr_Typ)
-                               or else not
-                                 Is_Variable_Size_Record (Etype (Expr_Typ)))
-                  then
-                     --  Copy the object
-
-                     Insert_Action (N,
-                       Make_Object_Declaration (Loc,
-                         Defining_Identifier => Obj_Id,
-                         Object_Definition   =>
-                           New_Occurrence_Of (Expr_Typ, Loc),
-                         Expression          => Relocate_Node (Expr_Q)));
-
-                     --  Statically reference the tag associated with the
-                     --  interface
-
-                     Tag_Comp :=
-                       Make_Selected_Component (Loc,
-                         Prefix        => New_Occurrence_Of (Obj_Id, Loc),
-                         Selector_Name =>
-                           New_Occurrence_Of
-                             (Find_Interface_Tag (Expr_Typ, Iface), Loc));
-
-                  --  Replace
                   --     IW : I'Class := Expr;
                   --  by
                   --     Dnn : Tag renames Tag_Ptr!(Expr'Address).all;
@@ -7665,7 +7630,7 @@ package body Exp_Ch3 is
                   --             Ityp!(Displace (Dnn'Address, I'Tag));
                   --     IW : I'Class renames Rnn.all;
 
-                  elsif Rewrite_As_Renaming then
+                  if Rewrite_As_Renaming then
                      New_Expr :=
                        Make_Explicit_Dereference (Loc,
                          Unchecked_Convert_To (RTE (RE_Tag_Ptr),
@@ -7700,6 +7665,37 @@ package body Exp_Ch3 is
                   --  Replace
                   --     IW : I'Class := Expr;
                   --  by
+                  --     Dnn : Typ := Expr;
+                  --     type Ityp is not null access I'Class;
+                  --     Rnn : constant Ityp := Ityp (Dnn.I_Tag'Address);
+                  --     IW  : I'Class renames Rnn.all;
+
+                  elsif Has_Tag_Of_Type (Expr_Q)
+                    and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
+                    and then (Expr_Typ = Etype (Expr_Typ)
+                               or else not
+                                 Is_Variable_Size_Record (Etype (Expr_Typ)))
+                  then
+                     Insert_Action (N,
+                       Make_Object_Declaration (Loc,
+                         Defining_Identifier => Obj_Id,
+                         Object_Definition   =>
+                           New_Occurrence_Of (Expr_Typ, Loc),
+                         Expression          => Relocate_Node (Expr_Q)));
+
+                     --  Statically reference the tag associated with the
+                     --  interface
+
+                     Tag_Comp :=
+                       Make_Selected_Component (Loc,
+                         Prefix        => New_Occurrence_Of (Obj_Id, Loc),
+                         Selector_Name =>
+                           New_Occurrence_Of
+                             (Find_Interface_Tag (Expr_Typ, Iface), Loc));
+
+                  --  Replace
+                  --     IW : I'Class := Expr;
+                  --  by
                   --     type Equiv_Record is record ... end record;
                   --     implicit subtype CW is <Class_Wide_Subtype>;
                   --     Dnn : CW := CW!(Expr);
@@ -7977,7 +7973,7 @@ package body Exp_Ch3 is
                 and then not (Is_Array_Type (Typ)
                                and then Is_Constr_Subt_For_UN_Aliased (Typ))
 
-                --  We may use a renaming if the initializing expression is a
+                --  We may use a renaming if the initialization expression is a
                 --  captured function call that meets a few conditions.
 
                 and then
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index f6d91ca4a0e..80c01bf40fd 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -7186,6 +7186,63 @@ package body Exp_Util is
       end if;
    end Has_Access_Constraint;
 
+   ---------------------
+   -- Has_Tag_Of_Type --
+   ---------------------
+
+   function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is
+      Typ : constant Entity_Id := Etype (Exp);
+
+   begin
+      pragma Assert (Is_Tagged_Type (Typ));
+
+      --  The tag of an object of a class-wide type is that of its
+      --  initialization expression.
+
+      if Is_Class_Wide_Type (Typ) then
+         return False;
+      end if;
+
+      --  The tag of a stand-alone object of a specific tagged type T
+      --  identifies T.
+
+      if Is_Entity_Name (Exp)
+        and then Ekind (Entity (Exp)) in E_Constant | E_Variable
+      then
+         return True;
+
+      else
+         case Nkind (Exp) is
+            --  The tag of a component or an aggregate of a specific tagged
+            --  type T identifies T.
+
+            when N_Indexed_Component
+              |  N_Selected_Component
+              |  N_Aggregate
+            =>
+               return True;
+
+            --  The tag of the result returned by a function whose result
+            --  type is a specific tagged type T identifies T.
+
+            when N_Function_Call =>
+               return True;
+
+            when N_Explicit_Dereference =>
+               return Is_Captured_Function_Call (Exp);
+
+            --  For a tagged type, the operand of a qualified expression
+            --  shall resolve to be of the type of the expression.
+
+            when N_Qualified_Expression =>
+               return Has_Tag_Of_Type (Expression (Exp));
+
+            when others =>
+               return False;
+         end case;
+      end if;
+   end Has_Tag_Of_Type;
+
    --------------------
    -- Homonym_Number --
    --------------------
@@ -9491,61 +9548,6 @@ package body Exp_Util is
       Size_Attr   : Node_Id;
       Size_Expr   : Node_Id;
 
-      function Has_Tag_Of_Type (Exp : Node_Id) return Boolean;
-      --  Return True if expression Exp of a tagged type is known to statically
-      --  have the tag of this tagged type as specified by RM 3.9(19-25).
-
-      ---------------------
-      -- Has_Tag_Of_Type --
-      ---------------------
-
-      function Has_Tag_Of_Type (Exp : Node_Id) return Boolean is
-         Typ : constant Entity_Id := Etype (Exp);
-
-      begin
-         pragma Assert (Is_Tagged_Type (Typ));
-
-         --  The tag of an object of a class-wide type is that of its
-         --  initialization expression.
-
-         if Is_Class_Wide_Type (Typ) then
-            return False;
-         end if;
-
-         --  The tag of a stand-alone object of a specific tagged type T
-         --  identifies T.
-
-         if Is_Entity_Name (Exp)
-           and then Ekind (Entity (Exp)) in E_Constant | E_Variable
-         then
-            return True;
-
-         else
-            case Nkind (Exp) is
-               --  The tag of a component or an aggregate of a specific tagged
-               --  type T identifies T.
-
-               when N_Indexed_Component
-                 |  N_Selected_Component
-                 |  N_Aggregate
-               =>
-                  return True;
-
-               --  The tag of the result returned by a function whose result
-               --  type is a specific tagged type T identifies T.
-
-               when N_Function_Call =>
-                  return True;
-
-               when N_Explicit_Dereference =>
-                  return Is_Captured_Function_Call (Exp);
-
-               when others =>
-                  return False;
-            end case;
-         end if;
-      end Has_Tag_Of_Type;
-
    begin
       --  If the root type is already constrained, there are no discriminants
       --  in the expression.
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 32f9c24814b..3dd10d77cea 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -732,6 +732,10 @@ package Exp_Util is
    function Has_Access_Constraint (E : Entity_Id) return Boolean;
    --  Given object or type E, determine if a discriminant is of an access type
 
+   function Has_Tag_Of_Type (Exp : Node_Id) return Boolean;
+   --  Return True if expression Exp of a tagged type is known to statically
+   --  have the tag of this tagged type as specified by RM 3.9(19-25).
+
    function Homonym_Number (Subp : Entity_Id) return Pos;
    --  Here subp is the entity for a subprogram. This routine returns the
    --  homonym number used to disambiguate overloaded subprograms in the same