[multiple changes]

2015-03-04  Robert Dewar  <dewar@adacore.com>

	* einfo.adb (Is_ARECnF_Entity): New flag (ARECnF is an extra formal).
	(Next_Formal): Don't return ARECnF formal.
	(Last_Formal): Don't consider ARECnF formal.
	(Next_Formal_With_Extras): Do consider ARECnF formal.
	* einfo.ads (Is_ARECnF_Entity): New flag (ARECnF is an extra formal).
	* exp_unst.adb (Create_Entities): Set Is_ARECnF_Entity flag.

2015-03-04  Javier Miranda  <miranda@adacore.com>

	* exp_ch6.adb (Expand_Simple_Function_Return): When the returned
	object is a class-wide interface object and we generate the
	accessibility described in RM 6.5(8/3) then displace the pointer
	to the object to reference the base of the object (to get access
	to the TSD of the object).

From-SVN: r221182

5 files changed, 138 insertions, 21 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 294a43e..386ae31 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,20 @@
+2015-03-04  Robert Dewar  <dewar@adacore.com>
+
+	* einfo.adb (Is_ARECnF_Entity): New flag (ARECnF is an extra formal).
+	(Next_Formal): Don't return ARECnF formal.
+	(Last_Formal): Don't consider ARECnF formal.
+	(Next_Formal_With_Extras): Do consider ARECnF formal.
+	* einfo.ads (Is_ARECnF_Entity): New flag (ARECnF is an extra formal).
+	* exp_unst.adb (Create_Entities): Set Is_ARECnF_Entity flag.
+
+2015-03-04  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch6.adb (Expand_Simple_Function_Return): When the returned
+	object is a class-wide interface object and we generate the
+	accessibility described in RM 6.5(8/3) then displace the pointer
+	to the object to reference the base of the object (to get access
+	to the TSD of the object).
+
 2015-03-04  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_prag.adb (Analyze_Abstract_State): Use routine
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 9ad146c..95776da 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -585,7 +585,7 @@ package body Einfo is
    --    Has_Nested_Subprogram           Flag282
    --    Uplevel_Reference_Noted         Flag283
 
-   --    (unused)                        Flag284
+   --    Is_ARECnF_Entity                Flag284
    --    (unused)                        Flag285
    --    (unused)                        Flag286
 
@@ -1901,6 +1901,11 @@ package body Einfo is
       return Flag146 (Id);
    end Is_Abstract_Type;
 
+   function Is_ARECnF_Entity (Id : E) return B is
+   begin
+      return Flag284 (Id);
+   end Is_ARECnF_Entity;
+
    function Is_Local_Anonymous_Access (Id : E) return B is
    begin
       pragma Assert (Is_Access_Type (Id));
@@ -4783,6 +4788,11 @@ package body Einfo is
       Set_Flag146 (Id, V);
    end Set_Is_Abstract_Type;
 
+   procedure Set_Is_ARECnF_Entity (Id : E; V : B := True) is
+   begin
+      Set_Flag284 (Id, V);
+   end Set_Is_ARECnF_Entity;
+
    procedure Set_Is_Local_Anonymous_Access (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Access_Type (Id));
@@ -7562,7 +7572,7 @@ package body Einfo is
 
    function Last_Formal (Id : E) return E is
       Formal : E;
-
+      NForm  : E;
    begin
       pragma Assert
         (Is_Overloadable (Id)
@@ -7577,8 +7587,10 @@ package body Einfo is
          Formal := First_Formal (Id);
 
          if Present (Formal) then
-            while Present (Next_Formal (Formal)) loop
-               Formal := Next_Formal (Formal);
+            loop
+               NForm := Next_Formal (Formal);
+               exit when No (NForm) or else Is_ARECnF_Entity (NForm);
+               Formal := NForm;
             end loop;
          end if;
 
@@ -7784,10 +7796,21 @@ package body Einfo is
 
       P := Id;
       loop
-         P := Next_Entity (P);
+         Next_Entity (P);
+
+         --  Return Empty if no next entity, or its an ARECnF entity (since
+         --  the latter is the last extra formal, not to be returned here).
 
-         if No (P) or else Is_Formal (P) then
+         if No (P) or else Is_ARECnF_Entity (P) then
+            return Empty;
+
+         --  If next entity is a formal, return it
+
+         elsif Is_Formal (P) then
             return P;
+
+         --  Else one, unless we have an internal entity, which we skip
+
          elsif not Is_Internal (P) then
             return Empty;
          end if;
@@ -7799,11 +7822,30 @@ package body Einfo is
    -----------------------------
 
    function Next_Formal_With_Extras (Id : E) return E is
+      NForm : Entity_Id;
+      Next  : Entity_Id;
+
    begin
       if Present (Extra_Formal (Id)) then
          return Extra_Formal (Id);
+
       else
-         return Next_Formal (Id);
+         NForm := Next_Formal (Id);
+
+         if Present (NForm) then
+            return NForm;
+
+         --  Deal with ARECnF entity as last extra formal
+
+         else
+            Next := Next_Entity (Id);
+
+            if Present (Next) and then Is_ARECnF_Entity (Next) then
+               return Next;
+            else
+               return Empty;
+            end if;
+         end if;
       end if;
    end Next_Formal_With_Extras;
 
@@ -8652,6 +8694,7 @@ package body Einfo is
       W ("In_Use",                          Flag8   (Id));
       W ("Is_Abstract_Subprogram",          Flag19  (Id));
       W ("Is_Abstract_Type",                Flag146 (Id));
+      W ("Is_ARECnF_Entity",                Flag284 (Id));
       W ("Is_Access_Constant",              Flag69  (Id));
       W ("Is_Ada_2005_Only",                Flag185 (Id));
       W ("Is_Ada_2012_Only",                Flag199 (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index dd51aa1..3b6f5be 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2176,6 +2176,15 @@ package Einfo is
 --       carry the keyword aliased, and on record components that have the
 --       keyword. For Ada 2012, also applies to formal parameters.
 
+--    Is_ARECnF_Entity (Flag284)
+--       Defined in all entities. Set for the ARECnF E_In_Parameter entity that
+--       is generated for nested subprograms that require an activation record.
+--       Logically this is an extra formal, and must be treated that way, but
+--       we can't use the normal Extra_Formal mechanism since it is designed
+--       to handle only cases where an extra formal is associated with one of
+--       the source formals, which is not the case for ARECnF entities. Hence
+--       we use this special flag to deal with this special extra formal.
+
 --    Is_Atomic (Flag85)
 --       Defined in all type entities, and also in constants, components and
 --       variables. Set if a pragma Atomic or Shared applies to the entity.
@@ -5248,6 +5257,7 @@ package Einfo is
    --    In_Private_Part                     (Flag45)
    --    Is_Ada_2005_Only                    (Flag185)
    --    Is_Ada_2012_Only                    (Flag199)
+   --    Is_ARECnF_Entity                    (Flag284)
    --    Is_Bit_Packed_Array                 (Flag122)  (base type only)
    --    Is_Aliased                          (Flag15)
    --    Is_Character_Type                   (Flag63)
@@ -6801,6 +6811,7 @@ package Einfo is
    function Is_Ada_2005_Only                    (Id : E) return B;
    function Is_Ada_2012_Only                    (Id : E) return B;
    function Is_Aliased                          (Id : E) return B;
+   function Is_ARECnF_Entity                    (Id : E) return B;
    function Is_Asynchronous                     (Id : E) return B;
    function Is_Atomic                           (Id : E) return B;
    function Is_Bit_Packed_Array                 (Id : E) return B;
@@ -7449,6 +7460,7 @@ package Einfo is
    procedure Set_Is_Ada_2005_Only                (Id : E; V : B := True);
    procedure Set_Is_Ada_2012_Only                (Id : E; V : B := True);
    procedure Set_Is_Aliased                      (Id : E; V : B := True);
+   procedure Set_Is_ARECnF_Entity                (Id : E; V : B := True);
    procedure Set_Is_Asynchronous                 (Id : E; V : B := True);
    procedure Set_Is_Atomic                       (Id : E; V : B := True);
    procedure Set_Is_Bit_Packed_Array             (Id : E; V : B := True);
@@ -8216,6 +8228,7 @@ package Einfo is
    pragma Inline (Is_Ada_2012_Only);
    pragma Inline (Is_Aggregate_Type);
    pragma Inline (Is_Aliased);
+   pragma Inline (Is_ARECnF_Entity);
    pragma Inline (Is_Array_Type);
    pragma Inline (Is_Assignable);
    pragma Inline (Is_Asynchronous);
@@ -8708,6 +8721,7 @@ package Einfo is
    pragma Inline (Set_Is_Ada_2005_Only);
    pragma Inline (Set_Is_Ada_2012_Only);
    pragma Inline (Set_Is_Aliased);
+   pragma Inline (Set_Is_ARECnF_Entity);
    pragma Inline (Set_Is_Asynchronous);
    pragma Inline (Set_Is_Atomic);
    pragma Inline (Set_Is_Bit_Packed_Array);
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index de360ab..0b9fb75 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -4379,7 +4379,7 @@ package body Exp_Ch6 is
            (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
 
          --  If the object decl was already rewritten as a renaming, then we
-         --  don't want to do the object allocation and transformation of of
+         --  don't want to do the object allocation and transformation of
          --  the return object declaration to a renaming. This case occurs
          --  when the return object is initialized by a call to another
          --  build-in-place function, and that function is responsible for
@@ -6266,18 +6266,60 @@ package body Exp_Ch6 is
 
             if Is_Class_Wide_Type (Etype (Exp))
               and then Is_Interface (Etype (Exp))
-              and then Nkind (Exp) = N_Explicit_Dereference
             then
-               Tag_Node :=
-                 Make_Explicit_Dereference (Loc,
-                   Prefix =>
-                     Unchecked_Convert_To (RTE (RE_Tag_Ptr),
-                       Make_Function_Call (Loc,
-                         Name                   =>
-                           New_Occurrence_Of (RTE (RE_Base_Address), Loc),
-                         Parameter_Associations => New_List (
-                           Unchecked_Convert_To (RTE (RE_Address),
-                             Duplicate_Subexpr (Prefix (Exp)))))));
+               --  If the expression is an explicit dereference then we can
+               --  directly displace the pointer to reference the base of
+               --  the object.
+
+               if Nkind (Exp) = N_Explicit_Dereference then
+                  Tag_Node :=
+                    Make_Explicit_Dereference (Loc,
+                      Prefix =>
+                        Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                          Make_Function_Call (Loc,
+                            Name                   =>
+                              New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+                            Parameter_Associations => New_List (
+                              Unchecked_Convert_To (RTE (RE_Address),
+                                Duplicate_Subexpr (Prefix (Exp)))))));
+
+               --  Similar case to the previous one but the expression is a
+               --  renaming of an explicit dereference.
+
+               elsif Nkind (Exp) = N_Identifier
+                 and then Present (Renamed_Object (Entity (Exp)))
+                 and then Nkind (Renamed_Object (Entity (Exp)))
+                            = N_Explicit_Dereference
+               then
+                  Tag_Node :=
+                    Make_Explicit_Dereference (Loc,
+                      Prefix =>
+                        Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                          Make_Function_Call (Loc,
+                            Name                   =>
+                              New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+                            Parameter_Associations => New_List (
+                              Unchecked_Convert_To (RTE (RE_Address),
+                                Duplicate_Subexpr
+                                  (Prefix
+                                    (Renamed_Object (Entity (Exp)))))))));
+
+               --  Common case: obtain the address of the actual object and
+               --  displace the pointer to reference the base of the object.
+
+               else
+                  Tag_Node :=
+                    Make_Explicit_Dereference (Loc,
+                      Prefix =>
+                        Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+                          Make_Function_Call (Loc,
+                            Name               =>
+                              New_Occurrence_Of (RTE (RE_Base_Address), Loc),
+                            Parameter_Associations => New_List (
+                              Make_Attribute_Reference (Loc,
+                                Prefix         => Duplicate_Subexpr (Exp),
+                                Attribute_Name => Name_Address)))));
+               end if;
             else
                Tag_Node :=
                  Make_Attribute_Reference (Loc,
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 9bb83e4..a850e78 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -591,7 +591,7 @@ package body Exp_Unst is
       --  at the start so that all the entities are defined, regardless of the
       --  order in which we do the code insertions.
 
-      for J in Subps.First .. Subps.Last loop
+      Create_Entities : for J in Subps.First .. Subps.Last loop
          declare
             STJ : Subp_Entry renames Subps.Table (J);
             Loc : constant Source_Ptr := Sloc (STJ.Bod);
@@ -611,6 +611,7 @@ package body Exp_Unst is
                STJ.ARECnF :=
                  Make_Defining_Identifier (Loc,
                    Chars => Name_Find_Str (AREC_String (STJ.Lev - 1) & "F"));
+               Set_Is_ARECnF_Entity (STJ.ARECnF, True);
             else
                STJ.ARECnF := Empty;
             end if;
@@ -654,7 +655,7 @@ package body Exp_Unst is
                STJ.ARECnU := Empty;
             end if;
          end;
-      end loop;
+      end loop Create_Entities;
 
       --  Loop through subprograms