ada: Factor out tag assignments from type in expander

They are performed in a few different places during expansion.

gcc/ada/

	* exp_util.ads (Make_Tag_Assignment_From_Type): Declare.
	* exp_util.adb (Make_Tag_Assignment_From_Type): New function.
	* exp_aggr.adb (Build_Record_Aggr_Code): Call the above function.
	(Initialize_Simple_Component): Likewise.
	* exp_ch3.adb (Build_Record_Init_Proc.Build_Assignment): Likewise.
	(Build_Record_Init_Proc.Build_Init_Procedure ): Likewise.
	(Make_Tag_Assignment): Likewise.  Rename local variable and call
	Unqualify to go through qualified expressions.
	* exp_ch4.adb (Expand_Allocator_Expression): Likewise.

5 files changed, 57 insertions, 124 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 8c6c9f9..c145d79 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -3095,22 +3095,9 @@ package body Exp_Aggr is
 
                if Tagged_Type_Expansion then
                   Instr :=
-                    Make_OK_Assignment_Statement (Loc,
-                      Name       =>
-                        Make_Selected_Component (Loc,
-                          Prefix        => New_Copy_Tree (Target),
-                          Selector_Name =>
-                            New_Occurrence_Of
-                              (First_Tag_Component (Base_Type (Typ)), Loc)),
-
-                      Expression =>
-                        Unchecked_Convert_To (RTE (RE_Tag),
-                          New_Occurrence_Of
-                            (Node (First_Elmt
-                               (Access_Disp_Table (Base_Type (Typ)))),
-                             Loc)));
+                    Make_Tag_Assignment_From_Type
+                      (Loc, New_Copy_Tree (Target), Base_Type (Typ));
 
-                  Set_Assignment_OK (Name (Instr));
                   Append_To (Assign, Instr);
 
                   --  Ada 2005 (AI-251): If tagged type has progenitors we must
@@ -3629,19 +3616,8 @@ package body Exp_Aggr is
 
       elsif Is_Tagged_Type (Typ) and then Tagged_Type_Expansion then
          Instr :=
-           Make_OK_Assignment_Statement (Loc,
-             Name =>
-               Make_Selected_Component (Loc,
-                 Prefix => New_Copy_Tree (Target),
-                 Selector_Name =>
-                   New_Occurrence_Of
-                     (First_Tag_Component (Base_Type (Typ)), Loc)),
-
-             Expression =>
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Occurrence_Of
-                   (Node (First_Elmt (Access_Disp_Table (Base_Type (Typ)))),
-                    Loc)));
+           Make_Tag_Assignment_From_Type
+             (Loc, New_Copy_Tree (Target), Base_Type (Typ));
 
          Append_To (L, Instr);
 
@@ -8761,19 +8737,8 @@ package body Exp_Aggr is
         and then Is_Tagged_Type (Comp_Typ)
       then
          Append_To (Blk_Stmts,
-           Make_OK_Assignment_Statement (Loc,
-             Name       =>
-               Make_Selected_Component (Loc,
-                 Prefix        => New_Copy_Tree (Comp),
-                 Selector_Name =>
-                   New_Occurrence_Of
-                     (First_Tag_Component (Full_Typ), Loc)),
-
-             Expression =>
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Occurrence_Of
-                   (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
-                    Loc))));
+           Make_Tag_Assignment_From_Type
+             (Loc, New_Copy_Tree (Comp), Full_Typ));
       end if;
 
       --  Adjust the component. In the case of an array aggregate, controlled
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 91dcfa0..fbedc16 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2150,21 +2150,10 @@ package body Exp_Ch3 is
            and then Nkind (Exp_Q) /= N_Raise_Expression
          then
             Append_To (Res,
-              Make_Assignment_Statement (Default_Loc,
-                Name       =>
-                  Make_Selected_Component (Default_Loc,
-                    Prefix        =>
-                      New_Copy_Tree (Lhs, New_Scope => Proc_Id),
-                    Selector_Name =>
-                      New_Occurrence_Of
-                        (First_Tag_Component (Typ), Default_Loc)),
-
-                Expression =>
-                  Unchecked_Convert_To (RTE (RE_Tag),
-                    New_Occurrence_Of
-                      (Node (First_Elmt (Access_Disp_Table (Underlying_Type
-                         (Typ)))),
-                       Default_Loc))));
+              Make_Tag_Assignment_From_Type
+                (Default_Loc,
+                 New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+                 Underlying_Type (Typ)));
          end if;
 
          --  Adjust the component if controlled except if it is an aggregate
@@ -2791,17 +2780,8 @@ package body Exp_Ch3 is
                --  Initialize the primary tag component
 
                Init_Tags_List := New_List (
-                 Make_Assignment_Statement (Loc,
-                   Name =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => Make_Identifier (Loc, Name_uInit),
-                       Selector_Name =>
-                         New_Occurrence_Of
-                           (First_Tag_Component (Rec_Type), Loc)),
-                   Expression =>
-                     New_Occurrence_Of
-                       (Node
-                         (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+                 Make_Tag_Assignment_From_Type
+                   (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
 
                --  Ada 2005 (AI-251): Initialize the secondary tags components
                --  located at fixed positions (tags whose position depends on
@@ -2880,17 +2860,8 @@ package body Exp_Ch3 is
                --  Initialize the primary tag
 
                Init_Tags_List := New_List (
-                 Make_Assignment_Statement (Loc,
-                   Name =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => Make_Identifier (Loc, Name_uInit),
-                       Selector_Name =>
-                         New_Occurrence_Of
-                           (First_Tag_Component (Rec_Type), Loc)),
-                   Expression =>
-                     New_Occurrence_Of
-                       (Node
-                         (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
+                 Make_Tag_Assignment_From_Type
+                   (Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
 
                --  Ada 2005 (AI-251): Initialize the secondary tags components
                --  located at fixed positions (tags whose position depends on
@@ -12078,13 +12049,11 @@ package body Exp_Ch3 is
 
    function Make_Tag_Assignment (N : Node_Id) return Node_Id is
       Loc      : constant Source_Ptr := Sloc (N);
-      Def_If   : constant Entity_Id  := Defining_Identifier (N);
+      Def_Id   : constant Entity_Id  := Defining_Identifier (N);
       Expr     : constant Node_Id    := Expression (N);
-      Typ      : constant Entity_Id  := Etype (Def_If);
+      Typ      : constant Entity_Id  := Etype (Def_Id);
       Full_Typ : constant Entity_Id  := Underlying_Type (Typ);
 
-      New_Ref  : Node_Id;
-
    begin
       --  This expansion activity is called during analysis
 
@@ -12092,25 +12061,12 @@ package body Exp_Ch3 is
         and then not Is_Class_Wide_Type (Typ)
         and then not Is_CPP_Class (Typ)
         and then Tagged_Type_Expansion
-        and then Nkind (Expr) /= N_Aggregate
-        and then (Nkind (Expr) /= N_Qualified_Expression
-                   or else Nkind (Expression (Expr)) /= N_Aggregate)
+        and then Nkind (Unqualify (Expr)) /= N_Aggregate
       then
-         New_Ref :=
-           Make_Selected_Component (Loc,
-             Prefix        => New_Occurrence_Of (Def_If, Loc),
-             Selector_Name =>
-               New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
-
-         Set_Assignment_OK (New_Ref);
-
          return
-           Make_Assignment_Statement (Loc,
-             Name       => New_Ref,
-             Expression =>
-               Unchecked_Convert_To (RTE (RE_Tag),
-                 New_Occurrence_Of
-                   (Node (First_Elmt (Access_Disp_Table (Full_Typ))), Loc)));
+           Make_Tag_Assignment_From_Type
+             (Loc, New_Occurrence_Of (Def_Id, Loc), Full_Typ);
+
       else
          return Empty;
       end if;
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 537d7a6..fdaeb505 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -567,7 +567,6 @@ package body Exp_Ch4 is
       Adj_Call      : Node_Id;
       Aggr_In_Place : Boolean;
       Node          : Node_Id;
-      Tag_Assign    : Node_Id;
       Temp          : Entity_Id;
       Temp_Decl     : Node_Id;
 
@@ -923,30 +922,9 @@ package body Exp_Ch4 is
          end if;
 
          if Present (TagT) then
-            declare
-               Full_T : constant Entity_Id := Underlying_Type (TagT);
-
-            begin
-               Tag_Assign :=
-                 Make_Assignment_Statement (Loc,
-                   Name       =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => TagR,
-                       Selector_Name =>
-                         New_Occurrence_Of
-                           (First_Tag_Component (Full_T), Loc)),
-
-                   Expression =>
-                     Unchecked_Convert_To (RTE (RE_Tag),
-                       New_Occurrence_Of
-                         (Elists.Node
-                           (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
-            end;
-
-            --  The previous assignment has to be done in any case
-
-            Set_Assignment_OK (Name (Tag_Assign));
-            Insert_Action (N, Tag_Assign);
+            Insert_Action (N,
+              Make_Tag_Assignment_From_Type
+                (Loc, TagR, Underlying_Type (TagT)));
          end if;
 
          --  Generate an Adjust call if the object will be moved. In Ada 2005,
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index da2d813..def027f 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -10335,6 +10335,33 @@ package body Exp_Util is
               Constraints => List_Constr));
    end Make_Subtype_From_Expr;
 
+   -----------------------------------
+   -- Make_Tag_Assignment_From_Type --
+   -----------------------------------
+
+   function Make_Tag_Assignment_From_Type
+     (Loc    : Source_Ptr;
+      Target : Node_Id;
+      Typ    : Entity_Id) return Node_Id
+   is
+      Nam : constant Node_Id :=
+              Make_Selected_Component (Loc,
+                Prefix => Target,
+                Selector_Name =>
+                  New_Occurrence_Of (First_Tag_Component (Typ), Loc));
+
+   begin
+      Set_Assignment_OK (Nam);
+
+      return
+        Make_Assignment_Statement (Loc,
+          Name       => Nam,
+          Expression =>
+            Unchecked_Convert_To (RTE (RE_Tag),
+              New_Occurrence_Of
+                (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)));
+   end Make_Tag_Assignment_From_Type;
+
    -----------------------------
    -- Make_Variant_Comparison --
    -----------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index eef6800..06bd414 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -925,6 +925,13 @@ package Exp_Util is
    --  wide type. Set Related_Id to request an external name for the subtype
    --  rather than an internal temporary.
 
+   function Make_Tag_Assignment_From_Type
+     (Loc    : Source_Ptr;
+      Target : Node_Id;
+      Typ    : Entity_Id) return Node_Id;
+   --  Return an assignment of the tag of tagged type Typ to prefix Target,
+   --  which must be a record object of a descendant of Typ.
+
    function Make_Variant_Comparison
      (Loc      : Source_Ptr;
       Typ      : Entity_Id;