exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove side effects from Tag_Arg early...

2013-01-02  Thomas Quinot  <quinot@adacore.com>

	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove
	side effects from Tag_Arg early, doing it too late may cause a
	crash due to inconsistent Parent link.
	* sem_ch8.adb, einfo.ads: Minor reformatting.

From-SVN: r194803

gcc/ada/ChangeLog

+2013-01-02  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Remove
+	side effects from Tag_Arg early, doing it too late may cause a
+	crash due to inconsistent Parent link.
+	* sem_ch8.adb, einfo.ads: Minor reformatting.
+
 2013-01-02  Robert Dewar  <dewar@adacore.com>
 
 	* einfo.ads, einfo.adb (Has_Independent_Components): New flag.

gcc/ada/einfo.ads

@@ -902,11 +902,11 @@ package Einfo is
 --    DTC_Entity (Node16)
 --       Defined in function and procedure entities. Set to Empty unless
 --       the subprogram is dispatching in which case it references the
---       Dispatch Table pointer Component. That is to say the component _tag
---       for regular Ada tagged types, for CPP_Class types and their
---       descendants this field points to the component entity in the record
---       that is the Vtable pointer for the Vtable containing the entry that
---       references the subprogram.
+--       Dispatch Table pointer Component. For regular Ada tagged this, this
+--       is the _Tag component. For CPP_Class types and their descendants,
+--       this points to the component entity in the record that holds the
+--       Vtable pointer for the Vtable containing the entry referencing the
+--       subprogram.
 
 --    DT_Entry_Count (Uint15)
 --       Defined in E_Component entities. Only used for component marked

gcc/ada/exp_intr.adb

@@ -210,6 +210,15 @@ package body Exp_Intr is
       Result_Typ : Entity_Id;
 
    begin
+      --  Remove side effects from tag argument early, before rewriting
+      --  the dispatching constructor call, as Remove_Side_Effects relies
+      --  on Tag_Arg's Parent link properly attached to the tree (once the
+      --  call is rewritten, the Parent is inconsistent as it points to the
+      --  rewritten node, which is not the syntactic parent of the Tag_Arg
+      --  anymore).
+
+      Remove_Side_Effects (Tag_Arg);
+
       --  The subprogram is the third actual in the instantiation, and is
       --  retrieved from the corresponding renaming declaration. However,
       --  freeze nodes may appear before, so we retrieve the declaration
@@ -223,15 +232,10 @@ package body Exp_Intr is
       Act_Constr := Entity (Name (Act_Rename));
       Result_Typ := Class_Wide_Type (Etype (Act_Constr));
 
-      --  Ada 2005 (AI-251): If the result is an interface type, the function
-      --  returns a class-wide interface type (otherwise the resulting object
-      --  would be abstract!)
-
       if Is_Interface (Etype (Act_Constr)) then
-         Set_Etype (Act_Constr, Result_Typ);
 
-         --  If the result type is not parent of Tag_Arg then we need to
-         --  locate the tag of the secondary dispatch table.
+         --  If the result type is not known to be a parent of Tag_Arg then we
+         --  need to locate the tag of the secondary dispatch table.
 
          if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg),
                              Use_Full_View => True)
@@ -255,7 +259,7 @@ package body Exp_Intr is
                      New_Reference_To (RTE (RE_Tag), Loc),
                    Expression          =>
                      Make_Function_Call (Loc,
-                       Name => Fname,
+                       Name                   => Fname,
                        Parameter_Associations => New_List (
                          Relocate_Node (Tag_Arg),
                          New_Reference_To
@@ -283,9 +287,7 @@ package body Exp_Intr is
          Set_Controlling_Argument (Cnstr_Call,
            New_Occurrence_Of (Defining_Identifier (Iface_Tag), Loc));
       else
-         Remove_Side_Effects (Tag_Arg);
-         Set_Controlling_Argument (Cnstr_Call,
-           Relocate_Node (Tag_Arg));
+         Set_Controlling_Argument (Cnstr_Call, Relocate_Node (Tag_Arg));
       end if;
 
       --  Rewrite and analyze the call to the instance as a class-wide
@@ -314,7 +316,7 @@ package body Exp_Intr is
 
       elsif not Is_Interface (Result_Typ) then
          declare
-            Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
+            Obj_Tag_Node : Node_Id := New_Copy_Tree (Tag_Arg);
             CW_Test_Node : Node_Id;
 
          begin
@@ -348,7 +350,7 @@ package body Exp_Intr is
                     Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
                     Parameter_Associations => New_List (
                       Make_Attribute_Reference (Loc,
-                        Prefix         => Duplicate_Subexpr (Tag_Arg),
+                        Prefix         => New_Copy_Tree (Tag_Arg),
                         Attribute_Name => Name_Address),
 
                       New_Reference_To (

gcc/ada/sem_ch8.adb

@@ -1906,7 +1906,7 @@ package body Sem_Ch8 is
             end loop;
 
             New_S := Analyze_Subprogram_Specification (Spec);
-            Result :=  Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+            Result := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
          end if;
 
          if Result /= Any_Id then