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

	* exp_ch7.adb (Process_Declarations): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object has
	been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.adb (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Finalizable_Transient): Minor reformatting.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.
	(Requires_Cleanup_Actions): Minor reformatting. Simplify the
	entry point for renamings. Detect a case where a source object
	has been transformed into a class-wide renaming of a call to
	Ada.Tags.Displace.
	* exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): New routine.
	(Is_Tag_To_Class_Wide_Conversion): Minor reformatting.

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

	* lib-load.adb (Load_Unit): If the prefix of the name in a
	with-clause is a renaming, add a with-clause on the original unit.
	* sem_ch10.adb (Build_Unit_Name): Remove code made obsolete by
	new handling of renamings in with-clauses.



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

5 files changed, 152 insertions, 42 deletions

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 7f5fcaaf90d..0347dcc5bd7 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -1816,7 +1816,7 @@ package body Exp_Ch7 is
                  and then Needs_Finalization (Obj_Typ)
                  and then not (Ekind (Obj_Id) = E_Constant
                                 and then not Has_Completion (Obj_Id))
-                 and then not Is_Tag_To_CW_Conversion (Obj_Id)
+                 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
                then
                   Processing_Actions;
 
@@ -1894,10 +1894,7 @@ package body Exp_Ch7 is
 
             --  Specific cases of object renamings
 
-            elsif Nkind (Decl) = N_Object_Renaming_Declaration
-              and then Nkind (Name (Decl)) = N_Explicit_Dereference
-              and then Nkind (Prefix (Name (Decl))) = N_Identifier
-            then
+            elsif Nkind (Decl) = N_Object_Renaming_Declaration then
                Obj_Id  := Defining_Identifier (Decl);
                Obj_Typ := Base_Type (Etype (Obj_Id));
 
@@ -1919,6 +1916,19 @@ package body Exp_Ch7 is
                  and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
                then
                   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.
+
+               --     Obj : Class_Wide_Type := Function_Call (...);
+
+               --     Temp : ... := Function_Call (...)'reference;
+               --     Obj  : Class_Wide_Type renames
+               --              (... Ada.Tags.Displace (Temp));
+
+               elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+                  Processing_Actions (Has_No_Init => True);
                end if;
 
             --  Inspect the freeze node of an access-to-controlled type and
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 98bd2f3b491..34bf030e205 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -3940,6 +3940,92 @@ package body Exp_Util is
       return True;
    end Is_All_Null_Statements;
 
+   ---------------------------------------------
+   -- Is_Displacement_Of_Ctrl_Function_Result --
+   ---------------------------------------------
+
+   function Is_Displacement_Of_Ctrl_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_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 Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is
+         Expr : constant Node_Id := Original_Node (Expression (N));
+
+      begin
+         return
+            Nkind (Expr) = N_Function_Call
+              and then Needs_Finalization (Etype (Expr));
+      end Initialized_By_Ctrl_Function;
+
+      ----------------------
+      -- Is_Displace_Call --
+      ----------------------
+
+      function Is_Displace_Call (N : Node_Id) return Boolean is
+         Call : Node_Id := N;
+
+      begin
+         --  Strip various actions which may precede a call to Displace
+
+         loop
+            if Nkind (Call) = N_Explicit_Dereference then
+               Call := Prefix (Call);
+
+            elsif Nkind_In (Call, N_Type_Conversion,
+                                  N_Unchecked_Type_Conversion)
+            then
+               Call := Expression (Call);
+            else
+               exit;
+            end if;
+         end loop;
+
+         return
+           Nkind (Call) = N_Function_Call
+             and then Is_RTE (Entity (Name (Call)), RE_Displace);
+      end Is_Displace_Call;
+
+      --  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
+
+   begin
+      --  Detect the following case:
+
+      --     Obj : Class_Wide_Type := Function_Call (...);
+
+      --  which is rewritten into:
+
+      --     Temp : ... := Function_Call (...)'reference;
+      --     Obj  : Class_Wide_Type renames (... Ada.Tags.Displace (Temp));
+
+      --  when the return type of the function 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;
+
    ------------------------------
    -- Is_Finalizable_Transient --
    ------------------------------
@@ -4321,7 +4407,7 @@ package body Exp_Util is
 
           --  Do not consider conversions of tags to class-wide types
 
-          and then not Is_Tag_To_CW_Conversion (Obj_Id)
+          and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
 
           --  Do not consider containers in the context of iterator loops. Such
           --  transient objects must exist for as long as the loop is around,
@@ -4851,11 +4937,13 @@ package body Exp_Util is
       end if;
    end Is_Renamed_Object;
 
-   -----------------------------
-   -- Is_Tag_To_CW_Conversion --
-   -----------------------------
+   -------------------------------------
+   -- Is_Tag_To_Class_Wide_Conversion --
+   -------------------------------------
 
-   function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
+   function Is_Tag_To_Class_Wide_Conversion
+     (Obj_Id : Entity_Id) return Boolean
+   is
       Expr : constant Node_Id := Expression (Parent (Obj_Id));
 
    begin
@@ -4864,7 +4952,7 @@ package body Exp_Util is
           and then Present (Expr)
           and then Nkind (Expr) = N_Unchecked_Type_Conversion
           and then Etype (Expression (Expr)) = RTE (RE_Tag);
-   end Is_Tag_To_CW_Conversion;
+   end Is_Tag_To_Class_Wide_Conversion;
 
    ----------------------------
    -- Is_Untagged_Derivation --
@@ -7015,7 +7103,7 @@ package body Exp_Util is
               and then Needs_Finalization (Obj_Typ)
               and then not (Ekind (Obj_Id) = E_Constant
                               and then not Has_Completion (Obj_Id))
-              and then not Is_Tag_To_CW_Conversion (Obj_Id)
+              and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
             then
                return True;
 
@@ -7064,10 +7152,7 @@ package body Exp_Util is
 
          --  Specific cases of object renamings
 
-         elsif Nkind (Decl) = N_Object_Renaming_Declaration
-           and then Nkind (Name (Decl)) = N_Explicit_Dereference
-           and then Nkind (Prefix (Name (Decl))) = N_Identifier
-         then
+         elsif Nkind (Decl) = N_Object_Renaming_Declaration then
             Obj_Id  := Defining_Identifier (Decl);
             Obj_Typ := Base_Type (Etype (Obj_Id));
 
@@ -7089,6 +7174,19 @@ package body Exp_Util is
               and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
             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.
+
+            --     Obj : Class_Wide_Type := Function_Call (...);
+
+            --     Temp : ... := Function_Call (...)'reference;
+            --     Obj  : Class_Wide_Type renames
+            --              (... Ada.Tags.Displace (Temp));
+
+            elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then
+               return True;
             end if;
 
          --  Inspect the freeze node of an access-to-controlled type and look
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index c0e0082185d..97e9b5c9a56 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -521,6 +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
+     (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.
+
    function Is_Finalizable_Transient
      (Decl     : Node_Id;
       Rel_Node : Node_Id) return Boolean;
@@ -587,7 +593,8 @@ package Exp_Util is
    --  We consider that a (1 .. 2) is a renamed object since it is the prefix
    --  of the name in the renaming declaration.
 
-   function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean;
+   function Is_Tag_To_Class_Wide_Conversion
+     (Obj_Id : Entity_Id) return Boolean;
    --  Determine whether object Obj_Id is the result of a tag-to-class-wide
    --  type conversion.
 
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 0ac729ece6c..be4c5376c36 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -406,9 +406,25 @@ package body Lib.Load is
               New_Child
                 (Load_Name, Get_Unit_Name (Name (Unit (Cunit (Unump)))));
 
+            --  If the load is for a with_clause, for visibility purposes both
+            --  the renamed entity and renaming one must be available in the
+            --  current unit: the renamed one in order to retrieve the child
+            --  unit, and the original one because it may be used as a prefix
+            --  in the body of the current unit. We add an explicit with_clause
+            --  for the original parent so that the renaming declaration is
+            --  properly loaded and analyzed.
+
+            if Present (With_Node) then
+               Insert_After (With_Node,
+                 Make_With_Clause (Sloc (With_Node),
+                   Name => Copy_Separate_Tree (Prefix (Name (With_Node)))));
+            end if;
+
             --  Save the renaming entity, to establish its visibility when
             --  installing the context. The implicit with is on this entity,
-            --  not on the package it renames.
+            --  not on the package it renames. This is somewhat redundant given
+            --  the with_clause just created, but it simplifies subsequent
+            --  expansion of the current with_clause. Optimizable ???
 
             if Nkind (Error_Node) = N_With_Clause
               and then Nkind (Name (Error_Node)) = N_Selected_Component
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index e2d1c2b5cd6..1aa25c2a542 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -2936,32 +2936,11 @@ package body Sem_Ch10 is
 
       function Build_Unit_Name (Nam : Node_Id) return Node_Id is
          Ent      : Entity_Id;
-         Renaming : Entity_Id;
          Result   : Node_Id;
 
       begin
          if Nkind (Nam) = N_Identifier then
-
-            --  If the parent unit P in the name of the with_clause for P.Q is
-            --  a renaming of package R, then the entity of the parent is set
-            --  to R, but the identifier retains Chars (P) to be consistent
-            --  with the source (see details in lib-load). However the implicit
-            --  with_clause for the parent must make the entity for P visible,
-            --  because P.Q may be used as a prefix within the current unit.
-            --  The entity for P is the current_entity with that name, because
-            --  the package renaming declaration for it has just been analyzed.
-            --  Note that this case can only happen if P.Q has already appeared
-            --  in a previous with_clause in a related unit, such as the
-            --  library body of the current unit.
-
-            if Chars (Nam) /= Chars (Entity (Nam)) then
-               Renaming := Current_Entity (Nam);
-               pragma Assert (Renamed_Entity (Renaming) = Entity (Nam));
-               return New_Occurrence_Of (Renaming, Loc);
-
-            else
-               return New_Occurrence_Of (Entity (Nam), Loc);
-            end if;
+            return New_Occurrence_Of (Entity (Nam), Loc);
 
          else
             Ent := Entity (Nam);