From 47a6f66054936affc847afa61eed3d245381e58b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 4 Mar 2015 11:27:59 +0100 Subject: [PATCH] [multiple changes] 2015-03-04 Robert Dewar * 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 * 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 --- gcc/ada/ChangeLog | 17 ++++++++++++ gcc/ada/einfo.adb | 57 +++++++++++++++++++++++++++++++++----- gcc/ada/einfo.ads | 14 ++++++++++ gcc/ada/exp_ch6.adb | 66 ++++++++++++++++++++++++++++++++++++-------- gcc/ada/exp_unst.adb | 5 ++-- 5 files changed, 138 insertions(+), 21 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 294a43ed739..386ae314f26 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2015-03-04 Robert Dewar + + * 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 + + * 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 * sem_prag.adb (Analyze_Abstract_State): Use routine diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9ad146c37ab..95776dad601 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 dd51aa15073..3b6f5be7abb 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 de360abf4c9..0b9fb75328b 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 9bb83e43554..a850e7816fa 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 -- 2.30.2