Patch Detail
get:
Show a patch.
patch:
Update a patch.
put:
Update a patch.
GET /api/patches/811450/?format=api
{ "id": 811450, "url": "http://patchwork.ozlabs.org/api/patches/811450/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/patch/20170908100256.GA106901@adacore.com/", "project": { "id": 17, "url": "http://patchwork.ozlabs.org/api/projects/17/?format=api", "name": "GNU Compiler Collection", "link_name": "gcc", "list_id": "gcc-patches.gcc.gnu.org", "list_email": "gcc-patches@gcc.gnu.org", "web_url": null, "scm_url": null, "webscm_url": null, "list_archive_url": "", "list_archive_url_format": "", "commit_url_format": "" }, "msgid": "<20170908100256.GA106901@adacore.com>", "list_archive_url": null, "date": "2017-09-08T10:02:56", "name": "[Ada] Generic dispatching constructors of limited interface types", "commit_ref": null, "pull_url": null, "state": "new", "archived": false, "hash": "da0171f3d233276584eb6352d5ca9732b45dec7d", "submitter": { "id": 4418, "url": "http://patchwork.ozlabs.org/api/people/4418/?format=api", "name": "Arnaud Charlet", "email": "charlet@adacore.com" }, "delegate": null, "mbox": "http://patchwork.ozlabs.org/project/gcc/patch/20170908100256.GA106901@adacore.com/mbox/", "series": [ { "id": 2166, "url": "http://patchwork.ozlabs.org/api/series/2166/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/list/?series=2166", "date": "2017-09-08T10:02:56", "name": "[Ada] Generic dispatching constructors of limited interface types", "version": 1, "mbox": "http://patchwork.ozlabs.org/series/2166/mbox/" } ], "comments": "http://patchwork.ozlabs.org/api/patches/811450/comments/", "check": "pending", "checks": "http://patchwork.ozlabs.org/api/patches/811450/checks/", "tags": {}, "related": [], "headers": { "Return-Path": "<gcc-patches-return-461714-incoming=patchwork.ozlabs.org@gcc.gnu.org>", "X-Original-To": "incoming@patchwork.ozlabs.org", "Delivered-To": [ "patchwork-incoming@bilbo.ozlabs.org", "mailing list gcc-patches@gcc.gnu.org" ], "Authentication-Results": [ "ozlabs.org;\n\tspf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org\n\t(client-ip=209.132.180.131; helo=sourceware.org;\n\tenvelope-from=gcc-patches-return-461714-incoming=patchwork.ozlabs.org@gcc.gnu.org;\n\treceiver=<UNKNOWN>)", "ozlabs.org; dkim=pass (1024-bit key;\n\tunprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org\n\theader.b=\"yCN5w3ck\"; dkim-atps=neutral", "sourceware.org; auth=none" ], "Received": [ "from sourceware.org (server1.sourceware.org [209.132.180.131])\n\t(using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256\n\tbits)) (No client certificate requested)\n\tby ozlabs.org (Postfix) with ESMTPS id 3xpXvZ0bCZz9s7C\n\tfor <incoming@patchwork.ozlabs.org>;\n\tFri, 8 Sep 2017 20:03:21 +1000 (AEST)", "(qmail 65412 invoked by alias); 8 Sep 2017 10:03:10 -0000", "(qmail 63688 invoked by uid 89); 8 Sep 2017 10:03:07 -0000", "from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by\n\tsourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP;\n\tFri, 08 Sep 2017 10:02:58 +0000", "from localhost (localhost.localdomain [127.0.0.1])\tby\n\tfiltered-rock.gnat.com (Postfix) with ESMTP id A990C56260;\n\tFri, 8 Sep 2017 06:02:56 -0400 (EDT)", "from rock.gnat.com ([127.0.0.1])\tby localhost (rock.gnat.com\n\t[127.0.0.1]) (amavisd-new, port 10024)\twith LMTP id\n\tO1Vxa6-ZNx53; Fri, 8 Sep 2017 06:02:56 -0400 (EDT)", "from tron.gnat.com (tron.gnat.com [205.232.38.10])\tby\n\trock.gnat.com (Postfix) with ESMTP id 938B15619D;\n\tFri, 8 Sep 2017 06:02:56 -0400 (EDT)", "by tron.gnat.com (Postfix, from userid 4192)\tid 8FEBC505;\n\tFri, 8 Sep 2017 06:02:56 -0400 (EDT)" ], "DomainKey-Signature": "a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; q=dns;\n\ts=default; b=e93YPrF3Ff5nssyXB6PZZRM7dcxA3csHWFSuFYd/Q9xQXpFX/k\n\t+QZy/K5gXZLFDb2Jw4pKTNawQoWx1++F7IcA+1kGlXjAfftqp1zk9ssBIZEljikE\n\t72pXaTlFKgKX/q3nwlv1tipT1Xj51CrIQpF+sN4yHidKFtdjv52FncflY=", "DKIM-Signature": "v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; s=\n\tdefault; bh=hBn2t80wrE4vIyUqsOeXzYpvieI=; b=yCN5w3ckHcRcak+gMoez\n\tuDKIvb8xwyufZoUxxw3e09cucKYg0njFn4F1N5ZGpXiKq6yGYzo6EYAmZYWlbWef\n\tMTJvse8Dp15dYjMH44IdxiCoVSYlU9o23GMlOOzRpYtYx27ziMkZ+Tu46rBHOOB4\n\ta+L/Da/NZ4pl/V0qY4m1onM=", "Mailing-List": "contact gcc-patches-help@gcc.gnu.org; run by ezmlm", "Precedence": "bulk", "List-Id": "<gcc-patches.gcc.gnu.org>", "List-Unsubscribe": "<mailto:gcc-patches-unsubscribe-incoming=patchwork.ozlabs.org@gcc.gnu.org>", "List-Archive": "<http://gcc.gnu.org/ml/gcc-patches/>", "List-Post": "<mailto:gcc-patches@gcc.gnu.org>", "List-Help": "<mailto:gcc-patches-help@gcc.gnu.org>", "Sender": "gcc-patches-owner@gcc.gnu.org", "X-Virus-Found": "No", "X-Spam-SWARE-Status": "No, score=-10.5 required=5.0 tests=AWL, BAYES_00,\n\tGIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS,\n\tRCVD_IN_DNSWL_NONE,\n\tSPF_PASS autolearn=ham version=3.3.2 spammy=", "X-HELO": "rock.gnat.com", "Date": "Fri, 8 Sep 2017 06:02:56 -0400", "From": "Arnaud Charlet <charlet@adacore.com>", "To": "gcc-patches@gcc.gnu.org", "Cc": "Javier Miranda <miranda@adacore.com>", "Subject": "[Ada] Generic dispatching constructors of limited interface types", "Message-ID": "<20170908100256.GA106901@adacore.com>", "MIME-Version": "1.0", "Content-Type": "multipart/mixed; boundary=\"liOOAslEiF7prFVr\"", "Content-Disposition": "inline", "User-Agent": "Mutt/1.5.23 (2014-03-12)" }, "content": "The compiler crashes processing a generic dispatching constructor\nthat is invoked to build-in-place objects that cover limited\ninterface types. After this patch the following test compiles\nwithout errors:\n\npackage Base is\n type Root is limited interface;\n function Constructor\n (Params : not null access String) return Root is abstract;\n function Factory\n (Params : not null access String) return Root'Class;\nend Base;\n\nwith Ada.Tags.Generic_Dispatching_Constructor;\nwith Ada.Tags;\npackage body Base is\n function Factory\n (Params : not null access String) return Root'Class\n is\n function C is\n new Ada.Tags.Generic_Dispatching_Constructor\n (T => Root,\n Parameters => String,\n Constructor => Base.Constructor);\n T : Ada.Tags.Tag;\n begin\n return Obj : Root'Class := C (T, Params); -- Test\n end Factory;\nend Base;\n\nTested on x86_64-pc-linux-gnu, committed on trunk\n\n2017-09-08 Javier Miranda <miranda@adacore.com>\n\n\t* exp_ch6.ads (Make_Build_In_Place_Iface_Call_In_Allocator): New\n\tsubprogram.\n\t(Make_Build_In_Place_Iface_Call_In_Anonymous_Context): New subprogram.\n\t(Make_Build_In_Place_Iface_Call_In_Object_Declaration): New\n\tsubprogram.\n\t(Unqual_BIP_Iface_Function_Call): New subprogram.\n\t* exp_ch6.adb (Replace_Renaming_Declaration_Id): New\n\tsubprogram containing code that was previously inside\n\tMake_Build_In_Place_Call_In_Object_Declaration since it is also\n\trequired for one of the new subprograms.\n\t(Expand_Actuals):\n\tInvoke Make_Build_In_Place_Iface_Call_In_Anonymous_Context\n\t(Expand_N_Extended_Return_Statement): Extend the\n\tcases covered by an assertion on expected BIP object\n\tdeclarations.\n\t(Make_Build_In_Place_Call_In_Assignment):\n\tRemoving unused code; found working on this ticket.\n\t(Make_Build_In_Place_Call_In_Object_Declaration): Move the code\n\tthat replaces the internal name of the renaming declaration\n\tinto the new subprogram Replace_Renaming_Declaration_Id.\n\t(Make_Build_In_Place_Iface_Call_In_Allocator): New subprogram.\n\t(Make_Build_In_Place_Iface_Call_In_Anonymous_Context):\n\tNew subprogram.\n\t(Make_Build_In_Place_Iface_Call_In_Object_Declaration): New\n\tsubprogram.\n\t(Unqual_BIP_Iface_Function_Call): New subprogram.\n\t* exp_ch3.adb (Expand_N_Object_Declaration): Invoke the new\n\tsubprogram Make_Build_In_Place_Iface_Call_In_Object_Declaration.\n\t* exp_attr.adb (Expand_N_Attribute_Reference): Invoke the new\n\tsubprogram Make_Build_In_Place_Iface_Call_In_Anonymous_Context.\n\t* exp_ch4.adb (Expand_Allocator_Expression): Invoke the new\n\tsubprogram Make_Build_In_Place_Iface_Call_In_Allocator.\n\t(Expand_N_Indexed_Component): Invoke the new subprogram\n\tMake_Build_In_Place_Iface_Call_In_Anonymous_Context.\n\t(Expand_N_Selected_Component): Invoke the new subprogram\n\tMake_Build_In_Place_Iface_Call_In_Anonymous_Context.\n\t(Expand_N_Slice): Invoke the new subprogram\n\tMake_Build_In_Place_Iface_Call_In_Anonymous_Context.\n\t* exp_ch8.adb (Expand_N_Object_Renaming_Declaration):\n\tInvoke the new subprogram\n\tMake_Build_In_Place_Iface_Call_In_Anonymous_Context.", "diff": "Index: einfo.adb\n===================================================================\n--- einfo.adb\t(revision 251876)\n+++ einfo.adb\t(working copy)\n@@ -9293,15 +9293,15 @@\n \n function Underlying_Type (Id : E) return E is\n begin\n- -- For record_with_private the underlying type is always the direct\n- -- full view. Never try to take the full view of the parent it\n- -- doesn't make sense.\n+ -- For record_with_private the underlying type is always the direct full\n+ -- view. Never try to take the full view of the parent it does not make\n+ -- sense.\n \n if Ekind (Id) = E_Record_Type_With_Private then\n return Full_View (Id);\n \n- -- If we have a class-wide type that comes from the limited view then\n- -- we return the Underlying_Type of its nonlimited view.\n+ -- If we have a class-wide type that comes from the limited view then we\n+ -- return the Underlying_Type of its nonlimited view.\n \n elsif Ekind (Id) = E_Class_Wide_Type\n and then From_Limited_With (Id)\n@@ -9311,8 +9311,8 @@\n \n elsif Ekind (Id) in Incomplete_Or_Private_Kind then\n \n- -- If we have an incomplete or private type with a full view,\n- -- then we return the Underlying_Type of this full view.\n+ -- If we have an incomplete or private type with a full view, then we\n+ -- return the Underlying_Type of this full view.\n \n if Present (Full_View (Id)) then\n if Id = Full_View (Id) then\n@@ -9347,10 +9347,9 @@\n elsif Etype (Id) /= Id then\n return Underlying_Type (Etype (Id));\n \n- -- Otherwise we have an incomplete or private type that has\n- -- no full view, which means that we have not encountered the\n- -- completion, so return Empty to indicate the underlying type\n- -- is not yet known.\n+ -- Otherwise we have an incomplete or private type that has no full\n+ -- view, which means that we have not encountered the completion, so\n+ -- return Empty to indicate the underlying type is not yet known.\n \n else\n return Empty;\nIndex: exp_attr.adb\n===================================================================\n--- exp_attr.adb\t(revision 251878)\n+++ exp_attr.adb\t(working copy)\n@@ -1761,6 +1761,15 @@\n and then Is_Build_In_Place_Function_Call (Pref)\n then\n Make_Build_In_Place_Call_In_Anonymous_Context (Pref);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix\n+ -- containing build-in-place function calls whose returned object covers\n+ -- interface types.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);\n end if;\n \n -- If prefix is a protected type name, this is a reference to the\nIndex: exp_ch3.adb\n===================================================================\n--- exp_ch3.adb\t(revision 251877)\n+++ exp_ch3.adb\t(working copy)\n@@ -6243,6 +6243,24 @@\n \n return;\n \n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for\n+ -- expressions containing a build-in-place function call whose\n+ -- returned object covers interface types, and Expr_Q has calls to\n+ -- Ada.Tags.Displace to displace the pointer to the returned build-\n+ -- in-place object to reference the secondary dispatch table of a\n+ -- covered interface type.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (Expr_Q))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Object_Declaration (N, Expr_Q);\n+\n+ -- The previous call expands the expression initializing the\n+ -- built-in-place object into further code that will be analyzed\n+ -- later. No further expansion needed here.\n+\n+ return;\n+\n -- Ada 2005 (AI-251): Rewrite the expression that initializes a\n -- class-wide interface object to ensure that we copy the full\n -- object, unless we are targetting a VM where interfaces are handled\nIndex: exp_ch4.adb\n===================================================================\n--- exp_ch4.adb\t(revision 251870)\n+++ exp_ch4.adb\t(working copy)\n@@ -804,6 +804,20 @@\n Make_Build_In_Place_Call_In_Allocator (N, Exp);\n Apply_Accessibility_Check (N, Built_In_Place => True);\n return;\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for\n+ -- expressions containing a build-in-place function call whose\n+ -- returned object covers interface types, and Expr has calls to\n+ -- Ada.Tags.Displace to displace the pointer to the returned build-\n+ -- in-place object to reference the secondary dispatch table of a\n+ -- covered interface type.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (Exp))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);\n+ Apply_Accessibility_Check (N, Built_In_Place => True);\n+ return;\n end if;\n \n -- Actions inserted before:\n@@ -6562,6 +6576,15 @@\n and then Is_Build_In_Place_Function_Call (P)\n then\n Make_Build_In_Place_Call_In_Anonymous_Context (P);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix\n+ -- containing build-in-place function calls whose returned object covers\n+ -- interface types.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (P))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);\n end if;\n \n -- If the prefix is an access type, then we unconditionally rewrite if\n@@ -10201,6 +10224,15 @@\n and then Is_Build_In_Place_Function_Call (P)\n then\n Make_Build_In_Place_Call_In_Anonymous_Context (P);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix\n+ -- containing build-in-place function calls whose returned object covers\n+ -- interface types.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (P))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (P);\n end if;\n \n -- Gigi cannot handle unchecked conversions that are the prefix of a\n@@ -10558,6 +10590,15 @@\n and then Is_Build_In_Place_Function_Call (Pref)\n then\n Make_Build_In_Place_Call_In_Anonymous_Context (Pref);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix\n+ -- containing build-in-place function calls whose returned object covers\n+ -- interface types.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (Pref))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);\n end if;\n \n -- The remaining case to be handled is packed slices. We can leave\nIndex: exp_ch5.adb\n===================================================================\n--- exp_ch5.adb\t(revision 251876)\n+++ exp_ch5.adb\t(working copy)\n@@ -4829,9 +4829,8 @@\n end if;\n \n else\n+ -- Initial value is smallest value in predicate\n \n- -- Initial value is smallest value in predicate.\n-\n if Is_Itype (Ltype) then\n D :=\n Make_Object_Declaration (Loc,\n@@ -4891,14 +4890,14 @@\n end if;\n \n S :=\n- Make_Assignment_Statement (Loc,\n- Name => New_Occurrence_Of (Loop_Id, Loc),\n- Expression =>\n- Make_Attribute_Reference (Loc,\n- Prefix => New_Occurrence_Of (Ltype, Loc),\n- Attribute_Name => Name_Next,\n- Expressions => New_List (\n- New_Occurrence_Of (Loop_Id, Loc))));\n+ Make_Assignment_Statement (Loc,\n+ Name => New_Occurrence_Of (Loop_Id, Loc),\n+ Expression =>\n+ Make_Attribute_Reference (Loc,\n+ Prefix => New_Occurrence_Of (Ltype, Loc),\n+ Attribute_Name => Name_Next,\n+ Expressions => New_List (\n+ New_Occurrence_Of (Loop_Id, Loc))));\n Set_Suppress_Assignment_Checks (S);\n end;\n \nIndex: exp_ch6.adb\n===================================================================\n--- exp_ch6.adb\t(revision 251877)\n+++ exp_ch6.adb\t(working copy)\n@@ -30,6 +30,7 @@\n with Einfo; use Einfo;\n with Errout; use Errout;\n with Elists; use Elists;\n+with Expander; use Expander;\n with Exp_Aggr; use Exp_Aggr;\n with Exp_Atag; use Exp_Atag;\n with Exp_Ch2; use Exp_Ch2;\n@@ -45,6 +46,7 @@\n with Exp_Util; use Exp_Util;\n with Freeze; use Freeze;\n with Inline; use Inline;\n+with Itypes; use Itypes;\n with Lib; use Lib;\n with Namet; use Namet;\n with Nlists; use Nlists;\n@@ -245,6 +247,19 @@\n -- Insert the Post_Call list previously produced by routine Expand_Actuals\n -- or Expand_Call_Helper into the tree.\n \n+ procedure Replace_Renaming_Declaration_Id\n+ (New_Decl : Node_Id;\n+ Orig_Decl : Node_Id);\n+ -- Replace the internal identifier of the new renaming declaration New_Decl\n+ -- with the identifier of its original declaration Orig_Decl exchanging the\n+ -- entities containing their defining identifiers to ensure the correct\n+ -- replacement of the object declaration by the object renaming declaration\n+ -- to avoid homograph conflicts (since the object declaration's defining\n+ -- identifier was already entered in the current scope). The Next_Entity\n+ -- links of the two entities are also swapped since the entities are part\n+ -- of the return scope's entity list and the list structure would otherwise\n+ -- be corrupted. The homonym chain is preserved as well.\n+\n procedure Rewrite_Function_Call_For_C (N : Node_Id);\n -- When generating C code, replace a call to a function that returns an\n -- array into the generated procedure with an additional out parameter.\n@@ -1878,6 +1893,13 @@\n \n if Is_Build_In_Place_Function_Call (Actual) then\n Make_Build_In_Place_Call_In_Anonymous_Context (Actual);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of the previous case for\n+ -- actuals containing build-in-place function calls whose returned\n+ -- object covers interface types.\n+\n+ elsif Present (Unqual_BIP_Iface_Function_Call (Actual)) then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Actual);\n end if;\n \n Apply_Constraint_Check (Actual, E_Formal);\n@@ -4793,9 +4815,20 @@\n then\n pragma Assert\n (Nkind (Original_Node (Ret_Obj_Decl)) = N_Object_Declaration\n- and then Is_Build_In_Place_Function_Call\n- (Expression (Original_Node (Ret_Obj_Decl))));\n+ and then\n \n+ -- It is a regular BIP object declaration\n+\n+ (Is_Build_In_Place_Function_Call\n+ (Expression (Original_Node (Ret_Obj_Decl)))\n+\n+ -- It is a BIP object declaration that displaces the pointer\n+ -- to the object to reference a convered interface type.\n+\n+ or else\n+ Present (Unqual_BIP_Iface_Function_Call\n+ (Expression (Original_Node (Ret_Obj_Decl))))));\n+\n -- Return the build-in-place result by reference\n \n Set_By_Ref (Return_Stmt);\n@@ -7952,7 +7985,6 @@\n Ptr_Typ_Decl : Node_Id;\n New_Expr : Node_Id;\n Result_Subt : Entity_Id;\n- Target : Node_Id;\n \n begin\n -- If the call has already been processed to add build-in-place actuals\n@@ -8038,26 +8070,6 @@\n Insert_After_And_Analyze (Ptr_Typ_Decl, Obj_Decl);\n \n Rewrite (Assign, Make_Null_Statement (Loc));\n-\n- -- Retrieve the target of the assignment\n-\n- if Nkind (Lhs) = N_Selected_Component then\n- Target := Selector_Name (Lhs);\n- elsif Nkind (Lhs) = N_Type_Conversion then\n- Target := Expression (Lhs);\n- else\n- Target := Lhs;\n- end if;\n-\n- -- If we are assigning to a return object or this is an expression of\n- -- an extension aggregate, the target should either be an identifier\n- -- or a simple expression. All other cases imply a different scenario.\n-\n- if Nkind (Target) in N_Has_Entity then\n- Target := Entity (Target);\n- else\n- return;\n- end if;\n end Make_Build_In_Place_Call_In_Assignment;\n \n ----------------------------------------------------\n@@ -8406,44 +8418,8 @@\n end if;\n \n Analyze (Obj_Decl);\n-\n- -- Replace the internal identifier of the renaming declaration's\n- -- entity with identifier of the original object entity. We also\n- -- have to exchange the entities containing their defining\n- -- identifiers to ensure the correct replacement of the object\n- -- declaration by the object renaming declaration to avoid\n- -- homograph conflicts (since the object declaration's defining\n- -- identifier was already entered in current scope). The\n- -- Next_Entity links of the two entities also have to be swapped\n- -- since the entities are part of the return scope's entity list\n- -- and the list structure would otherwise be corrupted. Finally,\n- -- the homonym chain must be preserved as well.\n-\n- declare\n- Ren_Id : constant Entity_Id := Defining_Entity (Obj_Decl);\n- Next_Id : constant Entity_Id := Next_Entity (Ren_Id);\n-\n- begin\n- Set_Chars (Ren_Id, Chars (Obj_Def_Id));\n-\n- -- Swap next entity links in preparation for exchanging\n- -- entities.\n-\n- Set_Next_Entity (Ren_Id, Next_Entity (Obj_Def_Id));\n- Set_Next_Entity (Obj_Def_Id, Next_Id);\n- Set_Homonym (Ren_Id, Homonym (Obj_Def_Id));\n-\n- Exchange_Entities (Ren_Id, Obj_Def_Id);\n-\n- -- Preserve source indication of original declaration, so that\n- -- xref information is properly generated for the right entity.\n-\n- Preserve_Comes_From_Source (Obj_Decl, Original_Node (Obj_Decl));\n- Preserve_Comes_From_Source\n- (Obj_Def_Id, Original_Node (Obj_Decl));\n-\n- Set_Comes_From_Source (Ren_Id, False);\n- end;\n+ Replace_Renaming_Declaration_Id\n+ (Obj_Decl, Original_Node (Obj_Decl));\n end if;\n end;\n \n@@ -8460,6 +8436,185 @@\n end if;\n end Make_Build_In_Place_Call_In_Object_Declaration;\n \n+ -------------------------------------------------\n+ -- Make_Build_In_Place_Iface_Call_In_Allocator --\n+ -------------------------------------------------\n+\n+ procedure Make_Build_In_Place_Iface_Call_In_Allocator\n+ (Allocator : Node_Id;\n+ Function_Call : Node_Id)\n+ is\n+ BIP_Func_Call : constant Node_Id :=\n+ Unqual_BIP_Iface_Function_Call (Function_Call);\n+ Loc : constant Source_Ptr := Sloc (Function_Call);\n+\n+ Anon_Type : Entity_Id;\n+ Tmp_Decl : Node_Id;\n+ Tmp_Id : Entity_Id;\n+\n+ begin\n+ -- No action of the call has already been processed\n+\n+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then\n+ return;\n+ end if;\n+\n+ Tmp_Id := Make_Temporary (Loc, 'D');\n+\n+ -- Insert a temporary before N initialized with the BIP function call\n+ -- without its enclosing type conversions and analyze it without its\n+ -- expansion. This temporary facilitates us reusing the BIP machinery,\n+ -- which takes care of adding the extra build-in-place actuals and\n+ -- transforms this object declaration into an object renaming\n+ -- declaration.\n+\n+ Anon_Type := Create_Itype (E_Anonymous_Access_Type, Function_Call);\n+ Set_Directly_Designated_Type (Anon_Type, Etype (BIP_Func_Call));\n+ Set_Etype (Anon_Type, Anon_Type);\n+\n+ Tmp_Decl :=\n+ Make_Object_Declaration (Loc,\n+ Defining_Identifier => Tmp_Id,\n+ Object_Definition => New_Occurrence_Of (Anon_Type, Loc),\n+ Expression =>\n+ Make_Allocator (Loc,\n+ Expression =>\n+ Make_Qualified_Expression (Loc,\n+ Subtype_Mark =>\n+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),\n+ Expression => New_Copy_Tree (BIP_Func_Call))));\n+\n+ Expander_Mode_Save_And_Set (False);\n+ Insert_Action (Allocator, Tmp_Decl);\n+ Expander_Mode_Restore;\n+\n+ Make_Build_In_Place_Call_In_Allocator\n+ (Allocator => Expression (Tmp_Decl),\n+ Function_Call => Expression (Expression (Tmp_Decl)));\n+\n+ Rewrite (Allocator, New_Occurrence_Of (Tmp_Id, Loc));\n+ end Make_Build_In_Place_Iface_Call_In_Allocator;\n+\n+ ---------------------------------------------------------\n+ -- Make_Build_In_Place_Iface_Call_In_Anonymous_Context --\n+ ---------------------------------------------------------\n+\n+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context\n+ (Function_Call : Node_Id)\n+ is\n+ BIP_Func_Call : constant Node_Id :=\n+ Unqual_BIP_Iface_Function_Call (Function_Call);\n+ Loc : constant Source_Ptr := Sloc (Function_Call);\n+\n+ Tmp_Decl : Node_Id;\n+ Tmp_Id : Entity_Id;\n+\n+ begin\n+ -- No action of the call has already been processed\n+\n+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then\n+ return;\n+ end if;\n+\n+ pragma Assert (Needs_Finalization (Etype (BIP_Func_Call)));\n+\n+ -- Insert a temporary before the call initialized with function call to\n+ -- reuse the BIP machinery which takes care of adding the extra build-in\n+ -- place actuals and transforms this object declaration into an object\n+ -- renaming declaration.\n+\n+ Tmp_Id := Make_Temporary (Loc, 'D');\n+\n+ Tmp_Decl :=\n+ Make_Object_Declaration (Loc,\n+ Defining_Identifier => Tmp_Id,\n+ Object_Definition =>\n+ New_Occurrence_Of (Etype (Function_Call), Loc),\n+ Expression => Relocate_Node (Function_Call));\n+\n+ Expander_Mode_Save_And_Set (False);\n+ Insert_Action (Function_Call, Tmp_Decl);\n+ Expander_Mode_Restore;\n+\n+ Make_Build_In_Place_Iface_Call_In_Object_Declaration\n+ (Obj_Decl => Tmp_Decl,\n+ Function_Call => Expression (Tmp_Decl));\n+ end Make_Build_In_Place_Iface_Call_In_Anonymous_Context;\n+\n+ ----------------------------------------------------------\n+ -- Make_Build_In_Place_Iface_Call_In_Object_Declaration --\n+ ----------------------------------------------------------\n+\n+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration\n+ (Obj_Decl : Node_Id;\n+ Function_Call : Node_Id)\n+ is\n+ BIP_Func_Call : constant Node_Id :=\n+ Unqual_BIP_Iface_Function_Call (Function_Call);\n+ Loc : constant Source_Ptr := Sloc (Function_Call);\n+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);\n+\n+ Tmp_Decl : Node_Id;\n+ Tmp_Id : Entity_Id;\n+\n+ begin\n+ -- No action of the call has already been processed\n+\n+ if Is_Expanded_Build_In_Place_Call (BIP_Func_Call) then\n+ return;\n+ end if;\n+\n+ Tmp_Id := Make_Temporary (Loc, 'D');\n+\n+ -- Insert a temporary before N initialized with the BIP function call\n+ -- without its enclosing type conversions and analyze it without its\n+ -- expansion. This temporary facilitates us reusing the BIP machinery,\n+ -- which takes care of adding the extra build-in-place actuals and\n+ -- transforms this object declaration into an object renaming\n+ -- declaration.\n+\n+ Tmp_Decl :=\n+ Make_Object_Declaration (Loc,\n+ Defining_Identifier => Tmp_Id,\n+ Object_Definition =>\n+ New_Occurrence_Of (Etype (BIP_Func_Call), Loc),\n+ Expression => New_Copy_Tree (BIP_Func_Call));\n+\n+ Expander_Mode_Save_And_Set (False);\n+ Insert_Action (Obj_Decl, Tmp_Decl);\n+ Expander_Mode_Restore;\n+\n+ Make_Build_In_Place_Call_In_Object_Declaration\n+ (Obj_Decl => Tmp_Decl,\n+ Function_Call => Expression (Tmp_Decl));\n+\n+ pragma Assert (Nkind (Tmp_Decl) = N_Object_Renaming_Declaration);\n+\n+ -- Replace the original build-in-place function call by a reference to\n+ -- the resulting temporary object renaming declaration. In this way,\n+ -- all the interface conversions performed in the original Function_Call\n+ -- on the build-in-place object are preserved.\n+\n+ Rewrite (BIP_Func_Call, New_Occurrence_Of (Tmp_Id, Loc));\n+\n+ -- Replace the original object declaration by an internal object\n+ -- renaming declaration. This leaves the generated code more clean (the\n+ -- build-in-place function call in an object renaming declaration and\n+ -- displacements of the pointer to the build-in-place object in another\n+ -- renaming declaration) and allows us to invoke the routine that takes\n+ -- care of replacing the identifier of the renaming declaration (routine\n+ -- originally developed for the regular build-in-place management).\n+\n+ Rewrite (Obj_Decl,\n+ Make_Object_Renaming_Declaration (Loc,\n+ Defining_Identifier => Make_Temporary (Loc, 'D'),\n+ Subtype_Mark => New_Occurrence_Of (Etype (Obj_Id), Loc),\n+ Name => Function_Call));\n+ Analyze (Obj_Decl);\n+\n+ Replace_Renaming_Declaration_Id (Obj_Decl, Original_Node (Obj_Decl));\n+ end Make_Build_In_Place_Iface_Call_In_Object_Declaration;\n+\n --------------------------------------------\n -- Make_CPP_Constructor_Call_In_Allocator --\n --------------------------------------------\n@@ -8713,6 +8868,41 @@\n end if;\n end Needs_Result_Accessibility_Level;\n \n+ -------------------------------------\n+ -- Replace_Renaming_Declaration_Id --\n+ -------------------------------------\n+\n+ procedure Replace_Renaming_Declaration_Id\n+ (New_Decl : Node_Id;\n+ Orig_Decl : Node_Id)\n+ is\n+ New_Id : constant Entity_Id := Defining_Entity (New_Decl);\n+ Orig_Id : constant Entity_Id := Defining_Entity (Orig_Decl);\n+\n+ begin\n+ Set_Chars (New_Id, Chars (Orig_Id));\n+\n+ -- Swap next entity links in preparation for exchanging entities\n+\n+ declare\n+ Next_Id : constant Entity_Id := Next_Entity (New_Id);\n+ begin\n+ Set_Next_Entity (New_Id, Next_Entity (Orig_Id));\n+ Set_Next_Entity (Orig_Id, Next_Id);\n+ end;\n+\n+ Set_Homonym (New_Id, Homonym (Orig_Id));\n+ Exchange_Entities (New_Id, Orig_Id);\n+\n+ -- Preserve source indication of original declaration, so that xref\n+ -- information is properly generated for the right entity.\n+\n+ Preserve_Comes_From_Source (New_Decl, Orig_Decl);\n+ Preserve_Comes_From_Source (Orig_Id, Orig_Decl);\n+\n+ Set_Comes_From_Source (New_Id, False);\n+ end Replace_Renaming_Declaration_Id;\n+\n ---------------------------------\n -- Rewrite_Function_Call_For_C --\n ---------------------------------\n@@ -8866,4 +9056,100 @@\n end loop;\n end Set_Enclosing_Sec_Stack_Return;\n \n+ ------------------------------------\n+ -- Unqual_BIP_Iface_Function_Call --\n+ ------------------------------------\n+\n+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id is\n+ Has_Pointer_Displacement : Boolean := False;\n+ On_Object_Declaration : Boolean := False;\n+ -- Remember if processing the renaming expressions on recursion we have\n+ -- traversed an object declaration, since we can traverse many object\n+ -- declaration renamings but just one regular object declaration.\n+\n+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id;\n+ -- Search for a build-in-place function call skipping any qualification\n+ -- including qualified expressions, type conversions, references, calls\n+ -- to displace the pointer to the object, and renamings. Return Empty if\n+ -- no build-in-place function call is found.\n+\n+ ------------------------------\n+ -- Unqual_BIP_Function_Call --\n+ ------------------------------\n+\n+ function Unqual_BIP_Function_Call (Expr : Node_Id) return Node_Id is\n+ begin\n+ -- Recurse to handle case of multiple levels of qualification and/or\n+ -- conversion.\n+\n+ if Nkind_In (Expr, N_Qualified_Expression,\n+ N_Type_Conversion,\n+ N_Unchecked_Type_Conversion)\n+ then\n+ return Unqual_BIP_Function_Call (Expression (Expr));\n+\n+ -- Recurse to handle case of multiple levels of references and\n+ -- explicit dereferences.\n+\n+ elsif Nkind_In (Expr, N_Attribute_Reference,\n+ N_Explicit_Dereference,\n+ N_Reference)\n+ then\n+ return Unqual_BIP_Function_Call (Prefix (Expr));\n+\n+ -- Recurse on object renamings\n+\n+ elsif Nkind (Expr) = N_Identifier\n+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)\n+ and then Nkind (Parent (Entity (Expr))) =\n+ N_Object_Renaming_Declaration\n+ and then Present (Renamed_Object (Entity (Expr)))\n+ then\n+ return Unqual_BIP_Function_Call (Renamed_Object (Entity (Expr)));\n+\n+ -- Recurse on the initializing expression of the first reference of\n+ -- an object declaration.\n+\n+ elsif not On_Object_Declaration\n+ and then Nkind (Expr) = N_Identifier\n+ and then Ekind_In (Entity (Expr), E_Constant, E_Variable)\n+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration\n+ and then Present (Expression (Parent (Entity (Expr))))\n+ then\n+ On_Object_Declaration := True;\n+ return\n+ Unqual_BIP_Function_Call (Expression (Parent (Entity (Expr))));\n+\n+ -- Recurse to handle calls to displace the pointer to the object to\n+ -- reference a secondary dispatch table.\n+\n+ elsif Nkind (Expr) = N_Function_Call\n+ and then Nkind (Name (Expr)) in N_Has_Entity\n+ and then RTU_Loaded (Ada_Tags)\n+ and then RTE_Available (RE_Displace)\n+ and then Is_RTE (Entity (Name (Expr)), RE_Displace)\n+ then\n+ Has_Pointer_Displacement := True;\n+ return\n+ Unqual_BIP_Function_Call (First (Parameter_Associations (Expr)));\n+\n+ -- Normal case: check if the inner expression is a BIP function call\n+ -- and the pointer to the object is displaced.\n+\n+ elsif Has_Pointer_Displacement\n+ and then Is_Build_In_Place_Function_Call (Expr)\n+ then\n+ return Expr;\n+\n+ else\n+ return Empty;\n+ end if;\n+ end Unqual_BIP_Function_Call;\n+\n+ -- Start of processing for Unqual_BIP_Iface_Function_Call\n+\n+ begin\n+ return Unqual_BIP_Function_Call (Expr);\n+ end Unqual_BIP_Iface_Function_Call;\n+\n end Exp_Ch6;\nIndex: exp_ch6.ads\n===================================================================\n--- exp_ch6.ads\t(revision 251863)\n+++ exp_ch6.ads\t(working copy)\n@@ -6,7 +6,7 @@\n -- --\n -- S p e c --\n -- --\n--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --\n+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --\n -- --\n -- GNAT is free software; you can redistribute it and/or modify it under --\n -- terms of the GNU General Public License as published by the Free Soft- --\n@@ -185,6 +185,40 @@\n -- for which Is_Build_In_Place_Call is True, or an N_Qualified_Expression\n -- node applied to such a function call.\n \n+ procedure Make_Build_In_Place_Iface_Call_In_Allocator\n+ (Allocator : Node_Id;\n+ Function_Call : Node_Id);\n+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that\n+ -- occurs as the expression initializing an allocator, by passing access\n+ -- to the allocated object as an additional parameter of the function call.\n+ -- Function_Call must denote an expression containing a BIP function call\n+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to\n+ -- the returned BIP object to reference the secondary dispatch table of\n+ -- an interface.\n+\n+ procedure Make_Build_In_Place_Iface_Call_In_Anonymous_Context\n+ (Function_Call : Node_Id);\n+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that\n+ -- occurs in a context that does not provide a separate object. A temporary\n+ -- object is created to act as the return object and an access to the\n+ -- temporary is passed as an additional parameter of the call. This occurs\n+ -- in contexts such as subprogram call actuals and object renamings.\n+ -- Function_Call must denote an expression containing a BIP function call\n+ -- and an enclosing call to Ada.Tags.Displace to displace the pointer to\n+ -- the returned BIP object to reference the secondary dispatch table of\n+ -- an interface.\n+\n+ procedure Make_Build_In_Place_Iface_Call_In_Object_Declaration\n+ (Obj_Decl : Node_Id;\n+ Function_Call : Node_Id);\n+ -- Ada 2005 (AI-318-02): Handle a call to a build-in-place function that\n+ -- occurs as the expression initializing an object declaration by passsing\n+ -- access to the declared object as an additional parameter of the function\n+ -- call. Function_Call must denote an expression containing a BIP function\n+ -- call and an enclosing call to Ada.Tags.Displace to displace the pointer\n+ -- to the returned BIP object to reference the secondary dispatch table of\n+ -- an interface.\n+\n procedure Make_CPP_Constructor_Call_In_Allocator\n (Allocator : Node_Id;\n Function_Call : Node_Id);\n@@ -211,4 +245,12 @@\n -- parameter to identify the accessibility level of the function result\n -- \"determined by the point of call\".\n \n+ function Unqual_BIP_Iface_Function_Call (Expr : Node_Id) return Node_Id;\n+ -- Return the inner BIP function call removing any qualification from Expr\n+ -- including qualified expressions, type conversions, references, unchecked\n+ -- conversions and calls to displace the pointer to the object, if Expr is\n+ -- an expression containing a call displacing the pointer to the BIP object\n+ -- to reference the secondary dispatch table of an interface; otherwise\n+ -- return Empty.\n+\n end Exp_Ch6;\nIndex: exp_ch8.adb\n===================================================================\n--- exp_ch8.adb\t(revision 251863)\n+++ exp_ch8.adb\t(working copy)\n@@ -6,7 +6,7 @@\n -- --\n -- B o d y --\n -- --\n--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --\n+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --\n -- --\n -- GNAT is free software; you can redistribute it and/or modify it under --\n -- terms of the GNU General Public License as published by the Free Soft- --\n@@ -185,6 +185,15 @@\n and then Is_Build_In_Place_Function_Call (Nam)\n then\n Make_Build_In_Place_Call_In_Anonymous_Context (Nam);\n+\n+ -- Ada 2005 (AI-318-02): Specialization of previous case for renaming\n+ -- containing build-in-place function calls whose returned object covers\n+ -- interface types.\n+\n+ elsif Ada_Version >= Ada_2005\n+ and then Present (Unqual_BIP_Iface_Function_Call (Nam))\n+ then\n+ Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);\n end if;\n \n -- Create renaming entry for debug information. Mark the entity as\nIndex: exp_util.adb\n===================================================================\n--- exp_util.adb\t(revision 251876)\n+++ exp_util.adb\t(working copy)\n@@ -3406,14 +3406,15 @@\n if Present (Priv_Typ) then\n Typ_Decl := Declaration_Node (Priv_Typ);\n \n- -- Derived types with the full view as parent do not have a partial\n- -- view. Insert the invariant procedure after the derived type.\n -- Anonymous arrays in object declarations have no explicit declaration\n -- so use the related object declaration as the insertion point.\n \n elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then\n Typ_Decl := Associated_Node_For_Itype (Work_Typ);\n \n+ -- Derived types with the full view as parent do not have a partial\n+ -- view. Insert the invariant procedure after the derived type.\n+\n else\n Typ_Decl := Declaration_Node (Full_Typ);\n end if;\nIndex: inline.adb\n===================================================================\n--- inline.adb\t(revision 251876)\n+++ inline.adb\t(working copy)\n@@ -1179,29 +1179,29 @@\n -- types.\n \n function Has_Some_Contract (Id : Entity_Id) return Boolean;\n- -- Returns True if subprogram Id has any contract (Pre, Post,\n- -- Global, Depends, etc.) The presence of Extensions_Visible\n- -- or Volatile_Function is also considered as a contract here.\n+ -- Return True if subprogram Id has any contract. The presence of\n+ -- Extensions_Visible or Volatile_Function is also considered as a\n+ -- contract here.\n \n function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;\n- -- Returns True if subprogram Id defines a compilation unit\n+ -- Return True if subprogram Id defines a compilation unit\n -- Shouldn't this be in Sem_Aux???\n \n function In_Package_Spec (Id : Node_Id) return Boolean;\n- -- Returns True if subprogram Id is defined in the package\n- -- specification, either its visible or private part.\n+ -- Return True if subprogram Id is defined in the package specification,\n+ -- either its visible or private part.\n \n ---------------------------------------------------\n -- Has_Formal_With_Discriminant_Dependent_Fields --\n ---------------------------------------------------\n \n function Has_Formal_With_Discriminant_Dependent_Fields\n- (Id : Entity_Id) return Boolean is\n-\n+ (Id : Entity_Id) return Boolean\n+ is\n function Has_Discriminant_Dependent_Component\n (Typ : Entity_Id) return Boolean;\n- -- Determine whether unconstrained record type Typ has at least\n- -- one component that depends on a discriminant.\n+ -- Determine whether unconstrained record type Typ has at least one\n+ -- component that depends on a discriminant.\n \n ------------------------------------------\n -- Has_Discriminant_Dependent_Component --\n@@ -1213,8 +1213,8 @@\n Comp : Entity_Id;\n \n begin\n- -- Inspect all components of the record type looking for one\n- -- that depends on a discriminant.\n+ -- Inspect all components of the record type looking for one that\n+ -- depends on a discriminant.\n \n Comp := First_Component (Typ);\n while Present (Comp) loop\nIndex: sem_ch4.adb\n===================================================================\n--- sem_ch4.adb\t(revision 251878)\n+++ sem_ch4.adb\t(working copy)\n@@ -6284,7 +6284,6 @@\n \n procedure Try_One_Interp (T1 : Entity_Id) is\n begin\n-\n -- If the operator is an expanded name, then the type of the operand\n -- must be defined in the corresponding scope. If the type is\n -- universal, the context will impose the correct type. Note that we\n@@ -6480,8 +6479,8 @@\n -- Note that we avoid returning if we are currently within a\n -- generic instance due to the fact that the generic package\n -- declaration has already been successfully analyzed and\n- -- Defined_In_Scope expects the base type to be defined within the\n- -- instance which will never be the case.\n+ -- Defined_In_Scope expects the base type to be defined within\n+ -- the instance which will never be the case.\n \n if Defined_In_Scope (T1, Scop)\n or else In_Instance\nIndex: sem_prag.adb\n===================================================================\n--- sem_prag.adb\t(revision 251878)\n+++ sem_prag.adb\t(working copy)\n@@ -17924,7 +17924,7 @@\n then\n declare\n Name : constant String :=\n- Get_Name_String (Chars (Variant));\n+ Get_Name_String (Chars (Variant));\n begin\n -- It is a common mistake to write \"Increasing\" for\n -- \"Increases\" or \"Decreasing\" for \"Decreases\". Recognize\n", "prefixes": [ "Ada" ] }