+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
-- Has_Nested_Subprogram Flag282
-- Uplevel_Reference_Noted Flag283
- -- (unused) Flag284
+ -- Is_ARECnF_Entity Flag284
-- (unused) Flag285
-- (unused) Flag286
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));
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));
function Last_Formal (Id : E) return E is
Formal : E;
-
+ NForm : E;
begin
pragma Assert
(Is_Overloadable (Id)
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;
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;
-----------------------------
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;
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));
-- 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.
-- 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)
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;
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);
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);
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);
(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
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,
-- 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);
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;
STJ.ARECnU := Empty;
end if;
end;
- end loop;
+ end loop Create_Entities;
-- Loop through subprograms
projects / gcc.git / commitdiff