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

1 files changed, 63 insertions, 32 deletions

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;