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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194803 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 15 insertions, 13 deletions

diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index c3389ddce82..b2c24c83101 100644
--- a/gcc/ada/exp_intr.adb
+++ b/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 (