exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped): Start examining the tree at the node passed to Establish_Transient_Scope (not...

2014-07-17  Thomas Quinot  <quinot@adacore.com>

	* exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped):
	Start examining the tree at the node passed to
	Establish_Transient_Scope (not its parent).
	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration):
	The access type for the variable storing the reference to
	the call must be declared and frozen prior to establishing a
	transient scope.
	* exp_ch9.adb: Minor reformatting.

From-SVN: r212718

4 files changed, 73 insertions, 46 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6d1c1b9..cbcba1d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2014-07-17  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_ch7.adb (Establish_Transient_Scope.Find_Node_To_Be_Wrapped):
+	Start examining the tree at the node passed to
+	Establish_Transient_Scope (not its parent).
+	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration):
+	The access type for the variable storing the reference to
+	the call must be declared and frozen prior to establishing a
+	transient scope.
+	* exp_ch9.adb: Minor reformatting.
+
 2014-07-17  Pascal Obry  <obry@adacore.com>
 
 	* s-os_lib.ads: Minor comment update.
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index a63d236..de0a4e2 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -10181,10 +10181,9 @@ package body Exp_Ch6 is
       Func_Call       : Node_Id := Function_Call;
       Function_Id     : Entity_Id;
       Pool_Actual     : Node_Id;
+      Ptr_Typ         : Entity_Id;
       Ptr_Typ_Decl    : Node_Id;
       Pass_Caller_Acc : Boolean := False;
-      New_Expr        : Node_Id;
-      Ref_Type        : Entity_Id;
       Res_Decl        : Node_Id;
       Result_Subt     : Entity_Id;
 
@@ -10224,6 +10223,53 @@ package body Exp_Ch6 is
 
       Result_Subt := Etype (Function_Id);
 
+      --  Create an access type designating the function's result subtype. We
+      --  use the type of the original call because it may be a call to an
+      --  inherited operation, which the expansion has replaced with the parent
+      --  operation that yields the parent type. Note that this access type
+      --  must be declared before we establish a transient scope, so that it
+      --  receives the proper accessibility level.
+
+      Ptr_Typ := Make_Temporary (Loc, 'A');
+      Ptr_Typ_Decl :=
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier => Ptr_Typ,
+          Type_Definition     =>
+            Make_Access_To_Object_Definition (Loc,
+              All_Present        => True,
+              Subtype_Indication =>
+                New_Occurrence_Of (Etype (Function_Call), Loc)));
+
+      --  The access type and its accompanying object must be inserted after
+      --  the object declaration in the constrained case, so that the function
+      --  call can be passed access to the object. In the unconstrained case,
+      --  or if the object declaration is for a return object, the access type
+      --  and object must be inserted before the object, since the object
+      --  declaration is rewritten to be a renaming of a dereference of the
+      --  access object. Note: we need to freeze Ptr_Typ explicitly, because
+      --  the result object is in a different (transient) scope, so won't
+      --  cause freezing.
+
+      if Is_Constrained (Underlying_Type (Result_Subt))
+        and then not Is_Return_Object (Defining_Identifier (Object_Decl))
+      then
+         Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
+      else
+         Insert_Action (Object_Decl, Ptr_Typ_Decl);
+      end if;
+
+      --  Force immediate freezing of Ptr_Typ because Res_Decl will be
+      --  elaborated in an inner (transient) scope and thus won't cause
+      --  freezing by itself.
+
+      declare
+         Ptr_Typ_Freeze_Ref : constant Node_Id :=
+                                New_Occurrence_Of (Ptr_Typ, Loc);
+      begin
+         Set_Parent (Ptr_Typ_Freeze_Ref, Ptr_Typ_Decl);
+         Freeze_Expression (Ptr_Typ_Freeze_Ref);
+      end;
+
       --  If the the object is a return object of an enclosing build-in-place
       --  function, then the implicit build-in-place parameters of the
       --  enclosing function are simply passed along to the called function.
@@ -10356,53 +10402,22 @@ package body Exp_Ch6 is
       Add_Access_Actual_To_Build_In_Place_Call
         (Func_Call, Function_Id, Caller_Object, Is_Access => Pass_Caller_Acc);
 
-      --  Create an access type designating the function's result subtype. We
-      --  use the type of the original expression because it may be a call to
-      --  an inherited operation, which the expansion has replaced with the
-      --  parent operation that yields the parent type.
-
-      Ref_Type := Make_Temporary (Loc, 'A');
-
-      Ptr_Typ_Decl :=
-        Make_Full_Type_Declaration (Loc,
-          Defining_Identifier => Ref_Type,
-          Type_Definition     =>
-            Make_Access_To_Object_Definition (Loc,
-              All_Present        => True,
-              Subtype_Indication =>
-                New_Occurrence_Of (Etype (Function_Call), Loc)));
-
-      --  The access type and its accompanying object must be inserted after
-      --  the object declaration in the constrained case, so that the function
-      --  call can be passed access to the object. In the unconstrained case,
-      --  or if the object declaration is for a return object, the access type
-      --  and object must be inserted before the object, since the object
-      --  declaration is rewritten to be a renaming of a dereference of the
-      --  access object.
-
-      if Is_Constrained (Underlying_Type (Result_Subt))
-        and then not Is_Return_Object (Defining_Identifier (Object_Decl))
-      then
-         Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
-      else
-         Insert_Action (Object_Decl, Ptr_Typ_Decl);
-      end if;
-
       --  Finally, create an access object initialized to a reference to the
       --  function call. We know this access value cannot be null, so mark the
       --  entity accordingly to suppress the access check.
 
-      New_Expr := Make_Reference (Loc, Relocate_Node (Func_Call));
-
-      Def_Id := Make_Temporary (Loc, 'R', New_Expr);
-      Set_Etype (Def_Id, Ref_Type);
+      Def_Id := Make_Temporary (Loc, 'R', Func_Call);
+      Set_Etype (Def_Id, Ptr_Typ);
       Set_Is_Known_Non_Null (Def_Id);
 
       Res_Decl :=
         Make_Object_Declaration (Loc,
           Defining_Identifier => Def_Id,
-          Object_Definition   => New_Occurrence_Of (Ref_Type, Loc),
-          Expression          => New_Expr);
+          Constant_Present    => True,
+          Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc),
+          Expression          =>
+            Make_Reference (Loc, Relocate_Node (Func_Call)));
+
       Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
 
       --  If the result subtype of the called function is constrained and
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 0603294..02c2219 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -4208,11 +4208,8 @@ package body Exp_Ch7 is
 
    begin
       The_Parent := N;
+      P          := Empty;
       loop
-         P := The_Parent;
-         pragma Assert (P /= Empty);
-         The_Parent := Parent (P);
-
          case Nkind (The_Parent) is
 
             --  Simple statement can be wrapped
@@ -4263,7 +4260,7 @@ package body Exp_Ch7 is
 
             --  The expression itself is to be wrapped if its parent is a
             --  compound statement or any other statement where the expression
-            --  is known to be scalar
+            --  is known to be scalar.
 
             when N_Accept_Alternative               |
                  N_Attribute_Definition_Clause      |
@@ -4279,6 +4276,7 @@ package body Exp_Ch7 is
                  N_If_Statement                     |
                  N_Iteration_Scheme                 |
                  N_Terminate_Alternative            =>
+               pragma Assert (Present (P));
                return P;
 
             when N_Attribute_Reference =>
@@ -4344,6 +4342,9 @@ package body Exp_Ch7 is
             when others =>
                null;
          end case;
+
+         P          := The_Parent;
+         The_Parent := Parent (P);
       end loop;
    end Find_Node_To_Be_Wrapped;
 
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index db66a8a..c5bd57a 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -4377,7 +4377,7 @@ package body Exp_Ch9 is
          pragma Assert (Ekind (Sub) = E_Function);
          Rewrite (N,
            Make_Function_Call (Loc,
-             Name => New_Sub,
+             Name                   => New_Sub,
              Parameter_Associations => Params));
       end if;