[Ada] Generic dispatching constructors of limited interface types
Arnaud Charlet
charlet@adacore.com
Fri Sep 8 10:03:00 GMT 2017
The compiler crashes processing a generic dispatching constructor
that is invoked to build-in-place objects that cover limited
interface types. After this patch the following test compiles
without errors:
package Base is
type Root is limited interface;
function Constructor
(Params : not null access String) return Root is abstract;
function Factory
(Params : not null access String) return Root'Class;
end Base;
with Ada.Tags.Generic_Dispatching_Constructor;
with Ada.Tags;
package body Base is
function Factory
(Params : not null access String) return Root'Class
is
function C is
new Ada.Tags.Generic_Dispatching_Constructor
(T => Root,
Parameters => String,
Constructor => Base.Constructor);
T : Ada.Tags.Tag;
begin
return Obj : Root'Class := C (T, Params); -- Test
end Factory;
end Base;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-08 Javier Miranda <miranda@adacore.com>
* exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New
subprogram.
(Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram.
(Make_Build_In_Place_Iface_Call_In_Object_Declaration): New
subprogram.
(Unqual_BIP_Iface_Function_Call): New subprogram.
* exp_ch6.adb (Replace_Renaming_Declaration_Id): New
subprogram containing code that was previously inside
Make_Build_In_Place_Call_In_Object_Declaration since it is also
required for one of the new subprograms.
(Expand_Actuals):
Invoke Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Expand_N_Extended_Return_Statement): Extend the
cases covered by an assertion on expected BIP object
declarations.
(Make_Build_In_Place_Call_In_Assignment):
Removing unused code; found working on this ticket.
(Make_Build_In_Place_Call_In_Object_Declaration): Move the code
that replaces the internal name of the renaming declaration
into the new subprogram Replace_Renaming_Declaration_Id.
(Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram.
(Make_Build_In_Place_Iface_Call_In_Anonymous_Context):
New subprogram.
(Make_Build_In_Place_Iface_Call_In_Object_Declaration): New
subprogram.
(Unqual_BIP_Iface_Function_Call): New subprogram.
* exp_ch3.adb (Expand_N_Object_Declaration): Invoke the new
subprogram Make_Build_In_Place_Iface_Call_In_Object_Declaration.
* exp_attr.adb (Expand_N_Attribute_Reference): Invoke the new
subprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
* exp_ch4.adb (Expand_Allocator_Expression): Invoke the new
subprogram Make_Build_In_Place_Iface_Call_In_Allocator.
(Expand_N_Indexed_Component): Invoke the new subprogram
Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
(Expand_N_Selected_Component): Invoke the new subprogram
Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
(Expand_N_Slice): Invoke the new subprogram
Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
* exp_ch8.adb (Expand_N_Object_Renaming_Declaration):
Invoke the new subprogram
Make_Build_In_Place_Iface_Call_In_Anonymous_Context.
-------------- next part --------------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 251876)
+++ einfo.adb (working copy)
@@ -9293,15 +9293,15 @@
function Underlying_Type (Id : E) return E is
begin
- -- For record_with_private the underlying type is always the direct
- -- full view. Never try to take the full view of the parent it
- -- doesn't make sense.
+ -- For record_with_private the underlying type is always the direct full
+ -- view. Never try to take the full view of the parent it does not make
+ -- sense.
if Ekind (Id) = E_Record_Type_With_Private then
return Full_View (Id);
- -- If we have a class-wide type that comes from the limited view then
- -- we return the Underlying_Type of its nonlimited view.
+ -- If we have a class-wide type that comes from the limited view then we
+ -- return the Underlying_Type of its nonlimited view.
elsif Ekind (Id) = E_Class_Wide_Type
and then From_Limited_With (Id)
@@ -9311,8 +9311,8 @@
elsif Ekind (Id) in Incomplete_Or_Private_Kind then
- -- If we have an incomplete or private type with a full view,
- -- then we return the Underlying_Type of this full view.
+ -- If we have an incomplete or private type with a full view, then we
+ -- return the Underlying_Type of this full view.
if Present (Full_View (Id)) then
if Id = Full_View (Id) then
@@ -9347,10 +9347,9 @@
elsif Etype (Id) /= Id then
return Underlying_Type (Etype (Id));
- -- Otherwise we have an incomplete or private type that has
- -- no full view, which means that we have not encountered the
- -- completion, so return Empty to indicate the underlying type
- -- is not yet known.
+ -- Otherwise we have an incomplete or private type that has no full
+ -- view, which means that we have not encountered the completion, so
+ -- return Empty to indicate the underlying type is not yet known.
else
return Empty;
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 251878)
+++ exp_attr.adb (working copy)
@@ -1761,6 +1761,15 @@
and then Is_Build_In_Place_Function_Call (Pref)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- If prefix is a protected type name, this is a reference to the
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 251877)
+++ exp_ch3.adb (working copy)
@@ -6243,6 +6243,24 @@
return;
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- expressions containing a build-in-place function call whose
+ -- returned object covers interface types, and Expr_Q has calls to
+ -- Ada.Tags.Displace to displace the pointer to the returned build-
+ -- in-place object to reference the secondary dispatch table of a
+ -- covered interface type.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q))
+ then
+ Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);
+
+ -- The previous call expands the expression initializing the
+ -- built-in-place object into further code that will be analyzed
+ -- later. No further expansion needed here.
+
+ return;
+
-- Ada 2005 (AI-251): Rewrite the expression that initializes a
-- class-wide interface object to ensure that we copy the full
-- object, unless we are targetting a VM where interfaces are handled
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 251870)
+++ exp_ch4.adb (working copy)
@@ -804,6 +804,20 @@
Make_Build_In_Place_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
return;
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- expressions containing a build-in-place function call whose
+ -- returned object covers interface types, and Expr has calls to
+ -- Ada.Tags.Displace to displace the pointer to the returned build-
+ -- in-place object to reference the secondary dispatch table of a
+ -- covered interface type.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Exp))
+ then
+ Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
+ Apply_Accessibility_Check (N, Built_In_Place => True);
+ return;
end if;
-- Actions inserted before:
@@ -6562,6 +6576,15 @@
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (P))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- If the prefix is an access type, then we unconditionally rewrite if
@@ -10201,6 +10224,15 @@
and then Is_Build_In_Place_Function_Call (P)
then
Make_Build_In_Place_Call_In_Anonymous_Context (P);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (P))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);
end if;
-- Gigi cannot handle unchecked conversions that are the prefix of a
@@ -10558,6 +10590,15 @@
and then Is_Build_In_Place_Function_Call (Pref)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
end if;
-- The remaining case to be handled is packed slices. We can leave
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 251876)
+++ exp_ch5.adb (working copy)
@@ -4829,9 +4829,8 @@
end if;
else
+ -- Initial value is smallest value in predicate
- -- Initial value is smallest value in predicate.
-
if Is_Itype (Ltype) then
D :=
Make_Object_Declaration (Loc,
@@ -4891,14 +4890,14 @@
end if;
S :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Loop_Id, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ltype, Loc),
- Attribute_Name => Name_Next,
- Expressions => New_List (
- New_Occurrence_Of (Loop_Id, Loc))));
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Loop_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ltype, Loc),
+ Attribute_Name => Name_Next,
+ Expressions => New_List (
+ New_Occurrence_Of (Loop_Id, Loc))));
Set_Suppress_Assignment_Checks (S);
end;
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 251877)
+++ exp_ch6.adb (working copy)
@@ -30,6 +30,7 @@
with Einfo; use Einfo;
with Errout; use Errout;
with Elists; use Elists;
+with Expander; use Expander;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch2; use Exp_Ch2;
@@ -45,6 +46,7 @@
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
+with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -245,6 +247,19 @@
-- Insert the Post_Call list previously produced by routine Expand_Actuals
-- or Expand_Call_Helper into the tree.
+ procedure Replace_Renaming_Declaration_Id
+ (New_Decl : Node_Id;
+ Orig_Decl : Node_Id);
+ -- Replace the internal identifier of the new renaming declaration New_Decl
+ -- with the identifier of its original declaration Orig_Decl exchanging the
+ -- entities containing their defining identifiers to ensure the correct
+ -- replacement of the object declaration by the object renaming declaration
+ -- to avoid homograph conflicts (since the object declaration's defining
+ -- identifier was already entered in the current scope). The Next_Entity
+ -- links of the two entities are also swapped since the entities are part
+ -- of the return scope's entity list and the list structure would otherwise
+ -- be corrupted. The homonym chain is preserved as well.
+
procedure Rewrite_Function_Call_For_C (N : Node_Id);
-- When generating C code, replace a call to a function that returns an
-- array into the generated procedure with an additional out parameter.
@@ -1878,6 +1893,13 @@
if Is_Build_In_Place_Function_Call (Actual) then
Make_Build_In_Place_Call_In_Anonymous_Context (Actual);
+
+ -- Ada 2005 (AI-318-02): Specialization of the previous case for
+ -- actuals containing build-in-place function calls whose returned
+ -- object covers interface types.
+
+ elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);
end if;
Apply_Constraint_Check (Actual, E_Formal);
@@ -4793,9 +4815,20 @@
then
pragma Assert
(Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration
- and then Is_Build_In_Place_Function_Call
- (Expression (Original_Node (Ret_Obj_Decl))));
+ and then
+ -- It is a regular BIP object declaration
+
+ (Is_Build_In_Place_Function_Call
+ (Expression (Original_Node (Ret_Obj_Decl)))
+
+ -- It is a BIP object declaration that displaces the pointer
+ -- to the object to reference a convered interface type.
+
+ or else
+ Present (Unqual_BIP_Iface_Function_Call
+ (Expression (Original_Node (Ret_Obj_Decl))))));
+
-- Return the build-in-place result by reference
Set_By_Ref (Return_Stmt);
@@ -7952,7 +7985,6 @@
Ptr_Typ_Decl : Node_Id;
New_Expr : Node_Id;
Result_Subt : Entity_Id;
- Target : Node_Id;
begin
-- If the call has already been processed to add build-in-place actuals
@@ -8038,26 +8070,6 @@
Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);
Rewrite (Assign, Make_Null_Statement (Loc));
-
- -- Retrieve the target of the assignment
-
- if Nkind (Lhs) = N_Selected_Component then
- Target := Selector_Name (Lhs);
- elsif Nkind (Lhs) = N_Type_Conversion then
- Target := Expression (Lhs);
- else
- Target := Lhs;
- end if;
-
- -- If we are assigning to a return object or this is an expression of
- -- an extension aggregate, the target should either be an identifier
- -- or a simple expression. All other cases imply a different scenario.
-
- if Nkind (Target) in N_Has_Entity then
- Target := Entity (Target);
- else
- return;
- end if;
end Make_Build_In_Place_Call_In_Assignment;
----------------------------------------------------
@@ -8406,44 +8418,8 @@
end if;
Analyze (Obj_Decl);
-
- -- Replace the internal identifier of the renaming declaration's
- -- entity with identifier of the original object entity. We also
- -- have to exchange the entities containing their defining
- -- identifiers to ensure the correct replacement of the object
- -- declaration by the object renaming declaration to avoid
- -- homograph conflicts (since the object declaration's defining
- -- identifier was already entered in current scope). The
- -- Next_Entity links of the two entities also have to be swapped
- -- since the entities are part of the return scope's entity list
- -- and the list structure would otherwise be corrupted. Finally,
- -- the homonym chain must be preserved as well.
-
- declare
- Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
- Next_Id : constant Entity_Id := Next_Entity (Ren_Id);
-
- begin
- Set_Chars (Ren_Id, Chars (Obj_Def_Id));
-
- -- Swap next entity links in preparation for exchanging
- -- entities.
-
- Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));
- Set_Next_Entity (Obj_Def_Id, Next_Id);
- Set_Homonym (Ren_Id, Homonym (Obj_Def_Id));
-
- Exchange_Entities (Ren_Id, Obj_Def_Id);
-
- -- Preserve source indication of original declaration, so that
- -- xref information is properly generated for the right entity.
-
- Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));
- Preserve_Comes_From_Source
- (Obj_Def_Id, Original_Node (Obj_Decl));
-
- Set_Comes_From_Source (Ren_Id, False);
- end;
+ Replace_Renaming_Declaration_Id
+ (Obj_Decl, Original_Node (Obj_Decl));
end if;
end;
@@ -8460,6 +8436,185 @@
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
+ -------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Allocator --
+ -------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Allocator
+ (Allocator : Node_Id;
+ Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+
+ Anon_Type : Entity_Id;
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ -- Insert a temporary before N initialized with the BIP function call
+ -- without its enclosing type conversions and analyze it without its
+ -- expansion. This temporary facilitates us reusing the BIP machinery,
+ -- which takes care of adding the extra build-in-place actuals and
+ -- transforms this object declaration into an object renaming
+ -- declaration.
+
+ Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);
+ Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));
+ Set_Etype (Anon_Type, Anon_Type);
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition => New_Occurrence_Of (Anon_Type, Loc),
+ Expression =>
+ Make_Allocator (Loc,
+ Expression =>
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
+ Expression => New_Copy_Tree (BIP_Func_Call))));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Allocator, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Call_In_Allocator
+ (Allocator => Expression (Tmp_Decl),
+ Function_Call => Expression (Expression (Tmp_Decl)));
+
+ Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));
+ end Make_Build_In_Place_Iface_Call_In_Allocator;
+
+ ---------------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --
+ ---------------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ (Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));
+
+ -- Insert a temporary before the call initialized with function call to
+ -- reuse the BIP machinery which takes care of adding the extra build-in
+ -- place actuals and transforms this object declaration into an object
+ -- renaming declaration.
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Function_Call), Loc),
+ Expression => Relocate_Node (Function_Call));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Function_Call, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl => Tmp_Decl,
+ Function_Call => Expression (Tmp_Decl));
+ end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;
+
+ ----------------------------------------------------------
+ -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --
+ ----------------------------------------------------------
+
+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl : Node_Id;
+ Function_Call : Node_Id)
+ is
+ BIP_Func_Call : constant Node_Id :=
+ Unqual_BIP_Iface_Function_Call (Function_Call);
+ Loc : constant Source_Ptr := Sloc (Function_Call);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+
+ Tmp_Decl : Node_Id;
+ Tmp_Id : Entity_Id;
+
+ begin
+ -- No action of the call has already been processed
+
+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then
+ return;
+ end if;
+
+ Tmp_Id := Make_Temporary (Loc, 'D');
+
+ -- Insert a temporary before N initialized with the BIP function call
+ -- without its enclosing type conversions and analyze it without its
+ -- expansion. This temporary facilitates us reusing the BIP machinery,
+ -- which takes care of adding the extra build-in-place actuals and
+ -- transforms this object declaration into an object renaming
+ -- declaration.
+
+ Tmp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tmp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),
+ Expression => New_Copy_Tree (BIP_Func_Call));
+
+ Expander_Mode_Save_And_Set (False);
+ Insert_Action (Obj_Decl, Tmp_Decl);
+ Expander_Mode_Restore;
+
+ Make_Build_In_Place_Call_In_Object_Declaration
+ (Obj_Decl => Tmp_Decl,
+ Function_Call => Expression (Tmp_Decl));
+
+ pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);
+
+ -- Replace the original build-in-place function call by a reference to
+ -- the resulting temporary object renaming declaration. In this way,
+ -- all the interface conversions performed in the original Function_Call
+ -- on the build-in-place object are preserved.
+
+ Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));
+
+ -- Replace the original object declaration by an internal object
+ -- renaming declaration. This leaves the generated code more clean (the
+ -- build-in-place function call in an object renaming declaration and
+ -- displacements of the pointer to the build-in-place object in another
+ -- renaming declaration) and allows us to invoke the routine that takes
+ -- care of replacing the identifier of the renaming declaration (routine
+ -- originally developed for the regular build-in-place management).
+
+ Rewrite (Obj_Decl,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'D'),
+ Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),
+ Name => Function_Call));
+ Analyze (Obj_Decl);
+
+ Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));
+ end Make_Build_In_Place_Iface_Call_In_Object_Declaration;
+
--------------------------------------------
-- Make_CPP_Constructor_Call_In_Allocator --
--------------------------------------------
@@ -8713,6 +8868,41 @@
end if;
end Needs_Result_Accessibility_Level;
+ -------------------------------------
+ -- Replace_Renaming_Declaration_Id --
+ -------------------------------------
+
+ procedure Replace_Renaming_Declaration_Id
+ (New_Decl : Node_Id;
+ Orig_Decl : Node_Id)
+ is
+ New_Id : constant Entity_Id := Defining_Entity (New_Decl);
+ Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);
+
+ begin
+ Set_Chars (New_Id, Chars (Orig_Id));
+
+ -- Swap next entity links in preparation for exchanging entities
+
+ declare
+ Next_Id : constant Entity_Id := Next_Entity (New_Id);
+ begin
+ Set_Next_Entity (New_Id, Next_Entity (Orig_Id));
+ Set_Next_Entity (Orig_Id, Next_Id);
+ end;
+
+ Set_Homonym (New_Id, Homonym (Orig_Id));
+ Exchange_Entities (New_Id, Orig_Id);
+
+ -- Preserve source indication of original declaration, so that xref
+ -- information is properly generated for the right entity.
+
+ Preserve_Comes_From_Source (New_Decl, Orig_Decl);
+ Preserve_Comes_From_Source (Orig_Id, Orig_Decl);
+
+ Set_Comes_From_Source (New_Id, False);
+ end Replace_Renaming_Declaration_Id;
+
---------------------------------
-- Rewrite_Function_Call_For_C --
---------------------------------
@@ -8866,4 +9056,100 @@
end loop;
end Set_Enclosing_Sec_Stack_Return;
+ ------------------------------------
+ -- Unqual_BIP_Iface_Function_Call --
+ ------------------------------------
+
+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is
+ Has_Pointer_Displacement : Boolean := False;
+ On_Object_Declaration : Boolean := False;
+ -- Remember if processing the renaming expressions on recursion we have
+ -- traversed an object declaration, since we can traverse many object
+ -- declaration renamings but just one regular object declaration.
+
+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;
+ -- Search for a build-in-place function call skipping any qualification
+ -- including qualified expressions, type conversions, references, calls
+ -- to displace the pointer to the object, and renamings. Return Empty if
+ -- no build-in-place function call is found.
+
+ ------------------------------
+ -- Unqual_BIP_Function_Call --
+ ------------------------------
+
+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is
+ begin
+ -- Recurse to handle case of multiple levels of qualification and/or
+ -- conversion.
+
+ if Nkind_In (Expr, N_Qualified_Expression,
+ N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ return Unqual_BIP_Function_Call (Expression (Expr));
+
+ -- Recurse to handle case of multiple levels of references and
+ -- explicit dereferences.
+
+ elsif Nkind_In (Expr, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Reference)
+ then
+ return Unqual_BIP_Function_Call (Prefix (Expr));
+
+ -- Recurse on object renamings
+
+ elsif Nkind (Expr) = N_Identifier
+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Nkind (Parent (Entity (Expr))) =
+ N_Object_Renaming_Declaration
+ and then Present (Renamed_Object (Entity (Expr)))
+ then
+ return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));
+
+ -- Recurse on the initializing expression of the first reference of
+ -- an object declaration.
+
+ elsif not On_Object_Declaration
+ and then Nkind (Expr) = N_Identifier
+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ and then Present (Expression (Parent (Entity (Expr))))
+ then
+ On_Object_Declaration := True;
+ return
+ Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));
+
+ -- Recurse to handle calls to displace the pointer to the object to
+ -- reference a secondary dispatch table.
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Nkind (Name (Expr)) in N_Has_Entity
+ and then RTU_Loaded (Ada_Tags)
+ and then RTE_Available (RE_Displace)
+ and then Is_RTE (Entity (Name (Expr)), RE_Displace)
+ then
+ Has_Pointer_Displacement := True;
+ return
+ Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));
+
+ -- Normal case: check if the inner expression is a BIP function call
+ -- and the pointer to the object is displaced.
+
+ elsif Has_Pointer_Displacement
+ and then Is_Build_In_Place_Function_Call (Expr)
+ then
+ return Expr;
+
+ else
+ return Empty;
+ end if;
+ end Unqual_BIP_Function_Call;
+
+ -- Start of processing for Unqual_BIP_Iface_Function_Call
+
+ begin
+ return Unqual_BIP_Function_Call (Expr);
+ end Unqual_BIP_Iface_Function_Call;
+
end Exp_Ch6;
Index: exp_ch6.ads
===================================================================
--- exp_ch6.ads (revision 251863)
+++ exp_ch6.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -185,6 +185,40 @@
-- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression
-- node applied to such a function call.
+ procedure Make_Build_In_Place_Iface_Call_In_Allocator
+ (Allocator : Node_Id;
+ Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs as the expression initializing an allocator, by passing access
+ -- to the allocated object as an additional parameter of the function call.
+ -- Function_Call must denote an expression containing a BIP function call
+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to
+ -- the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context
+ (Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs in a context that does not provide a separate object. A temporary
+ -- object is created to act as the return object and an access to the
+ -- temporary is passed as an additional parameter of the call. This occurs
+ -- in contexts such as subprogram call actuals and object renamings.
+ -- Function_Call must denote an expression containing a BIP function call
+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to
+ -- the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration
+ (Obj_Decl : Node_Id;
+ Function_Call : Node_Id);
+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that
+ -- occurs as the expression initializing an object declaration by passsing
+ -- access to the declared object as an additional parameter of the function
+ -- call. Function_Call must denote an expression containing a BIP function
+ -- call and an enclosing call to Ada.Tags.Displace to displace the pointer
+ -- to the returned BIP object to reference the secondary dispatch table of
+ -- an interface.
+
procedure Make_CPP_Constructor_Call_In_Allocator
(Allocator : Node_Id;
Function_Call : Node_Id);
@@ -211,4 +245,12 @@
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id;
+ -- Return the inner BIP function call removing any qualification from Expr
+ -- including qualified expressions, type conversions, references, unchecked
+ -- conversions and calls to displace the pointer to the object, if Expr is
+ -- an expression containing a call displacing the pointer to the BIP object
+ -- to reference the secondary dispatch table of an interface; otherwise
+ -- return Empty.
+
end Exp_Ch6;
Index: exp_ch8.adb
===================================================================
--- exp_ch8.adb (revision 251863)
+++ exp_ch8.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
@@ -185,6 +185,15 @@
and then Is_Build_In_Place_Function_Call (Nam)
then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
+
+ -- Ada 2005 (AI-318-02): Specialization of previous case for renaming
+ -- containing build-in-place function calls whose returned object covers
+ -- interface types.
+
+ elsif Ada_Version >= Ada_2005
+ and then Present (Unqual_BIP_Iface_Function_Call (Nam))
+ then
+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information. Mark the entity as
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 251876)
+++ exp_util.adb (working copy)
@@ -3406,14 +3406,15 @@
if Present (Priv_Typ) then
Typ_Decl := Declaration_Node (Priv_Typ);
- -- Derived types with the full view as parent do not have a partial
- -- view. Insert the invariant procedure after the derived type.
-- Anonymous arrays in object declarations have no explicit declaration
-- so use the related object declaration as the insertion point.
elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
Typ_Decl := Associated_Node_For_Itype (Work_Typ);
+ -- Derived types with the full view as parent do not have a partial
+ -- view. Insert the invariant procedure after the derived type.
+
else
Typ_Decl := Declaration_Node (Full_Typ);
end if;
Index: inline.adb
===================================================================
--- inline.adb (revision 251876)
+++ inline.adb (working copy)
@@ -1179,29 +1179,29 @@
-- types.
function Has_Some_Contract (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id has any contract (Pre, Post,
- -- Global, Depends, etc.) The presence of Extensions_Visible
- -- or Volatile_Function is also considered as a contract here.
+ -- Return True if subprogram Id has any contract. The presence of
+ -- Extensions_Visible or Volatile_Function is also considered as a
+ -- contract here.
function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
- -- Returns True if subprogram Id defines a compilation unit
+ -- Return True if subprogram Id defines a compilation unit
-- Shouldn't this be in Sem_Aux???
function In_Package_Spec (Id : Node_Id) return Boolean;
- -- Returns True if subprogram Id is defined in the package
- -- specification, either its visible or private part.
+ -- Return True if subprogram Id is defined in the package specification,
+ -- either its visible or private part.
---------------------------------------------------
-- Has_Formal_With_Discriminant_Dependent_Fields --
---------------------------------------------------
function Has_Formal_With_Discriminant_Dependent_Fields
- (Id : Entity_Id) return Boolean is
-
+ (Id : Entity_Id) return Boolean
+ is
function Has_Discriminant_Dependent_Component
(Typ : Entity_Id) return Boolean;
- -- Determine whether unconstrained record type Typ has at least
- -- one component that depends on a discriminant.
+ -- Determine whether unconstrained record type Typ has at least one
+ -- component that depends on a discriminant.
------------------------------------------
-- Has_Discriminant_Dependent_Component --
@@ -1213,8 +1213,8 @@
Comp : Entity_Id;
begin
- -- Inspect all components of the record type looking for one
- -- that depends on a discriminant.
+ -- Inspect all components of the record type looking for one that
+ -- depends on a discriminant.
Comp := First_Component (Typ);
while Present (Comp) loop
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb (revision 251878)
+++ sem_ch4.adb (working copy)
@@ -6284,7 +6284,6 @@
procedure Try_One_Interp (T1 : Entity_Id) is
begin
-
-- If the operator is an expanded name, then the type of the operand
-- must be defined in the corresponding scope. If the type is
-- universal, the context will impose the correct type. Note that we
@@ -6480,8 +6479,8 @@
-- Note that we avoid returning if we are currently within a
-- generic instance due to the fact that the generic package
-- declaration has already been successfully analyzed and
- -- Defined_In_Scope expects the base type to be defined within the
- -- instance which will never be the case.
+ -- Defined_In_Scope expects the base type to be defined within
+ -- the instance which will never be the case.
if Defined_In_Scope (T1, Scop)
or else In_Instance
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 251878)
+++ sem_prag.adb (working copy)
@@ -17924,7 +17924,7 @@
then
declare
Name : constant String :=
- Get_Name_String (Chars (Variant));
+ Get_Name_String (Chars (Variant));
begin
-- It is a common mistake to write "Increasing" for
-- "Increases" or "Decreasing" for "Decreases". Recognize
More information about the Gcc-patches
mailing list