2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Detect a case where
	a source object was initialized by another source object,
	but the expression was rewritten as a class-wide conversion
	of Ada.Tags.Displace.
	* exp_util.adb (Initialized_By_Ctrl_Function): Removed.
	(Is_Controlled_Function_Call): New routine.
	(Is_Displacement_Of_Ctrl_Function_Result): Removed.
	(Is_Displacement_Of_Object_Or_Function_Result): New routine.
	(Is_Source_Object): New routine.
	(Requires_Cleanup_Actions): Detect a case where a source object was
	initialized by another source object, but the expression was rewritten
	as a class-wide conversion of Ada.Tags.Displace.
	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed.
	(Is_Displacement_Of_Object_Or_Function_Result): New routine.

2012-04-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Call): A call to an expression function
	does not freeze if it appears in a different scope from the
	expression function itself. Such calls appear in the generated
	bodies of other expression functions, or in pre/postconditions
	of subsequent subprograms.



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

5 files changed, 113 insertions, 44 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 904c9cc3b00..f42c041af5f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,28 @@
+2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch7.adb (Process_Declarations): Detect a case where
+	a source object was initialized by another source object,
+	but the expression was rewritten as a class-wide conversion
+	of Ada.Tags.Displace.
+	* exp_util.adb (Initialized_By_Ctrl_Function): Removed.
+	(Is_Controlled_Function_Call): New routine.
+	(Is_Displacement_Of_Ctrl_Function_Result): Removed.
+	(Is_Displacement_Of_Object_Or_Function_Result): New routine.
+	(Is_Source_Object): New routine.
+	(Requires_Cleanup_Actions): Detect a case where a source object was
+	initialized by another source object, but the expression was rewritten
+	as a class-wide conversion of Ada.Tags.Displace.
+	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed.
+	(Is_Displacement_Of_Object_Or_Function_Result): New routine.
+
+2012-04-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_res.adb (Resolve_Call): A call to an expression function
+	does not freeze if it appears in a different scope from the
+	expression function itself. Such calls appear in the generated
+	bodies of other expression functions, or in pre/postconditions
+	of subsequent subprograms.
+
 2012-04-02  Yannick Moy  <moy@adacore.com>
 
 	* lib-xref-alfa.adb: Code clean up.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 525bae71e44..f8730f3d9ab 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1917,16 +1917,17 @@ package body Exp_Ch7 is
                   Processing_Actions (Has_No_Init => True);
 
                --  Detect a case where a source object has been initialized by
-               --  a controlled function call which was later rewritten as a
-               --  class-wide conversion of Ada.Tags.Displace.
+               --  a controlled function call or another object which was later
+               --  rewritten as a class-wide conversion of Ada.Tags.Displace.
 
-               --     Obj : Class_Wide_Type := Function_Call (...);
+               --     Obj1 : CW_Type := Src_Obj;
+               --     Obj2 : CW_Type := Function_Call (...);
 
-               --     Temp : ... := Function_Call (...)'reference;
-               --     Obj  : Class_Wide_Type renames
-               --              (... Ada.Tags.Displace (Temp));
+               --     Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+               --     Tmp  : ... := Function_Call (...)'reference;
+               --     Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
 
-               elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+               elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
                   Processing_Actions (Has_No_Init => True);
                end if;
 
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 335ba10c9db..b43bd16edd1 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -3940,27 +3940,30 @@ package body Exp_Util is
       return True;
    end Is_All_Null_Statements;
 
-   ---------------------------------------------
-   -- Is_Displacement_Of_Ctrl_Function_Result --
-   ---------------------------------------------
+   --------------------------------------------------
+   -- Is_Displacement_Of_Object_Or_Function_Result --
+   --------------------------------------------------
 
-   function Is_Displacement_Of_Ctrl_Function_Result
+   function Is_Displacement_Of_Object_Or_Function_Result
      (Obj_Id : Entity_Id) return Boolean
    is
-      function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean;
-      --  Determine whether object declaration N is initialized by a controlled
-      --  function call.
+      function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
+      --  Determine whether a particular node denotes a controlled function
+      --  call.
 
       function Is_Displace_Call (N : Node_Id) return Boolean;
       --  Determine whether a particular node is a call to Ada.Tags.Displace.
       --  The call might be nested within other actions such as conversions.
 
-      ----------------------------------
-      -- Initialized_By_Ctrl_Function --
-      ----------------------------------
+      function Is_Source_Object (N : Node_Id) return Boolean;
+      --  Determine whether a particular node denotes a source object
+
+      ---------------------------------
+      -- Is_Controlled_Function_Call --
+      ---------------------------------
 
-      function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
-         Expr : Node_Id := Original_Node (Expression (N));
+      function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
+         Expr : Node_Id := Original_Node (N);
 
       begin
          if Nkind (Expr) = N_Function_Call then
@@ -3977,7 +3980,7 @@ package body Exp_Util is
            Nkind_In (Expr, N_Expanded_Name, N_Identifier)
              and then Ekind (Entity (Expr)) = E_Function
              and then Needs_Finalization (Etype (Entity (Expr)));
-      end Initialized_By_Ctrl_Function;
+      end Is_Controlled_Function_Call;
 
       ----------------------
       -- Is_Displace_Call --
@@ -4004,39 +4007,66 @@ package body Exp_Util is
          end loop;
 
          return
-           Nkind (Call) = N_Function_Call
+           Present (Call)
+             and then Nkind (Call) = N_Function_Call
              and then Is_RTE (Entity (Name (Call)), RE_Displace);
       end Is_Displace_Call;
 
+      ----------------------
+      -- Is_Source_Object --
+      ----------------------
+
+      function Is_Source_Object (N : Node_Id) return Boolean is
+      begin
+         return
+           Present (N)
+             and then Nkind (N) in N_Has_Entity
+             and then Is_Object (Entity (N))
+             and then Comes_From_Source (N);
+      end Is_Source_Object;
+
       --  Local variables
 
       Decl      : constant Node_Id   := Parent (Obj_Id);
       Obj_Typ   : constant Entity_Id := Base_Type (Etype (Obj_Id));
       Orig_Decl : constant Node_Id   := Original_Node (Decl);
 
-   --  Start of processing for Is_Displacement_Of_Ctrl_Function_Result
+   --  Start of processing for Is_Displacement_Of_Object_Or_Function_Result
 
    begin
-      --  Detect the following case:
+      --  Case 1:
 
-      --     Obj : Class_Wide_Type := Function_Call (...);
+      --     Obj : CW_Type := Function_Call (...);
 
-      --  which is rewritten into:
+      --  rewritten into:
 
-      --     Temp : ... := Function_Call (...)'reference;
-      --     Obj  : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
+      --     Tmp : ... := Function_Call (...)'reference;
+      --     Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
 
-      --  when the return type of the function and the class-wide type require
+      --  where the return type of the function and the class-wide type require
+      --  dispatch table pointer displacement.
+
+      --  Case 2:
+
+      --     Obj : CW_Type := Src_Obj;
+
+      --  rewritten into:
+
+      --     Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+
+      --  where the type of the source object and the class-wide type require
       --  dispatch table pointer displacement.
 
       return
         Nkind (Decl) = N_Object_Renaming_Declaration
           and then Nkind (Orig_Decl) = N_Object_Declaration
           and then Comes_From_Source (Orig_Decl)
-          and then Initialized_By_Ctrl_Function (Orig_Decl)
           and then Is_Class_Wide_Type (Obj_Typ)
-          and then Is_Displace_Call (Renamed_Object (Obj_Id));
-   end Is_Displacement_Of_Ctrl_Function_Result;
+          and then Is_Displace_Call (Renamed_Object (Obj_Id))
+          and then
+            (Is_Controlled_Function_Call (Expression (Orig_Decl))
+               or else Is_Source_Object (Expression (Orig_Decl)));
+   end Is_Displacement_Of_Object_Or_Function_Result;
 
    ------------------------------
    -- Is_Finalizable_Transient --
@@ -7189,17 +7219,18 @@ package body Exp_Util is
             then
                return True;
 
-            --  Detect a case where a source object has been initialized by a
-            --  controlled function call which was later rewritten as a class-
-            --  wide conversion of Ada.Tags.Displace.
+            --  Detect a case where a source object has been initialized by
+            --  a controlled function call or another object which was later
+            --  rewritten as a class-wide conversion of Ada.Tags.Displace.
 
-            --     Obj : Class_Wide_Type := Function_Call (...);
+            --     Obj1 : CW_Type := Src_Obj;
+            --     Obj2 : CW_Type := Function_Call (...);
 
-            --     Temp : ... := Function_Call (...)'reference;
-            --     Obj  : Class_Wide_Type renames
-            --              (... Ada.Tags.Displace (Temp));
+            --     Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
+            --     Tmp  : ... := Function_Call (...)'reference;
+            --     Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
 
-            elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+            elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
                return True;
             end if;
 
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 535a4ffe2fd..9f3ae2a2554 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -521,11 +521,12 @@ package Exp_Util is
    --  False otherwise. True for an empty list. It is an error to call this
    --  routine with No_List as the argument.
 
-   function Is_Displacement_Of_Ctrl_Function_Result
+   function Is_Displacement_Of_Object_Or_Function_Result
      (Obj_Id : Entity_Id) return Boolean;
-   --  Determine whether Obj_Id is a source object that has been initialized by
-   --  a controlled function call later rewritten as a class-wide conversion of
-   --  Ada.Tags.Displace.
+   --  Determine whether Obj_Id is a source entity that has been initialized by
+   --  either a controlled function call or the assignment of another source
+   --  object. In both cases the initialization expression is rewritten as a
+   --  class-wide conversion of Ada.Tags.Displace.
 
    function Is_Finalizable_Transient
      (Decl     : Node_Id;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 46a8b194853..fc95bb8ed2d 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5316,7 +5316,18 @@ package body Sem_Res is
       --  needs extending because we can generate procedure calls that need
       --  freezing.
 
-      if Is_Entity_Name (Subp) and then not In_Spec_Expression then
+      --  In Ada 2012, expression functions may be called within pre/post
+      --  conditions of subsequent functions or expression functions. Such
+      --  calls do not freeze when they appear within generated bodies, which
+      --  would place the freeze node in the wrong scope.  An expression
+      --  function is frozen in the usual fashion, by the appearance of a real
+      --  body, or at the end of a declarative part.
+
+      if Is_Entity_Name (Subp) and then not In_Spec_Expression
+        and then
+          (not Is_Expression_Function (Entity (Subp))
+            or else Scope (Entity (Subp)) = Current_Scope)
+      then
          Freeze_Expression (Subp);
       end if;