Skip to content

R
riscv-gcc-1
Commit 47a6f660 by Arnaud Charlet
Options

[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
parent 55067169
Showing with 138 additions and 21 deletions
gcc/ada/ChangeLog
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
......
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));
......
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);
......
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,
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment