From patchwork Tue Nov 21 10:00:20 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 80436 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 4B0C53858291 for ; Tue, 21 Nov 2023 10:01:12 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x432.google.com (mail-wr1-x432.google.com [IPv6:2a00:1450:4864:20::432]) by sourceware.org (Postfix) with ESMTPS id CBAB93857C5E for ; Tue, 21 Nov 2023 10:00:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CBAB93857C5E Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org CBAB93857C5E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::432 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1700560833; cv=none; b=kaV4Hz6cse0vbucaHwIh1Lnouxm4VYhilqKEPmSUi+f1zGwj0rUBGz2veLp0s/K/YWu7drP2nOgskiP2qcEacBWX19L78/kn4T/Z0mZc6FOuzQnxhlXSMuCfupc+54A0CuR14tuJyBxYp+gVQzllWq/5Xo2hicvkqFlVZ1SCE8g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1700560833; c=relaxed/simple; bh=VRe6hbJ9bVKrbpHwi791w8zK6HpLf73+cBXQ5b9pMWw=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=FU5/wZAvoX/Ts/+xDP7Fj0eejztboZ/b0+Jx5gngg5PXDrZdxW/X0chxZaLOqEogEAfxcjrfYfgX2BO9p3R9WKoZzLQgQNtx/5q2q7sC4leIf/RgYi/UcwhB68lT2WUeCJjdSJ17Fz1Vic2qn7EXRE9NkNtvImwvxihZPoJl3Dw= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wr1-x432.google.com with SMTP id ffacd0b85a97d-32fe1a29010so3401088f8f.0 for ; Tue, 21 Nov 2023 02:00:23 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1700560822; x=1701165622; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=YSRoMeieu2qoUO0olPMsYQRgN9+OKqvtsE5xN9t/Smw=; b=YfeImQPwhawTtC7BHztHkV0OAnJXwBbHykwJW1PmXDMG3RRysDdomcclAZaGbto4Jg U9msKrRJMSV0HK+uv+kq4isKndtdLE5FJv/1Phsz5SsW3y2EhXOp0V9gNTJ48FUnM8og f/zUaVaiuWLhlun/sQBSuiQrhvE8qdgfEolIvG5PGWr8qCYtsK6MmcxxkGJ7r3HbXXsN 26hMtd6dWJRlllF4tWuFUr3mIjf3ua9ecZdrmwgQwAmjHUIsbVKTbq0kYW5nwfdWX2+W IGYiL/lV7BAikfIagkjGQ2cQMZf02lds+NBsiGXD80a4OibqIvRzRDsWjq1rtzdTjSY4 Wpew== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1700560822; x=1701165622; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=YSRoMeieu2qoUO0olPMsYQRgN9+OKqvtsE5xN9t/Smw=; b=cqKxUou4m8QzT3EJPq4VB6mbAfn0d8fne9CdiNbj5p+XibbxF9LTXkhNciPsfvdbPR p4hJQRgEhCWBT1h7Dq6f3XZrOIAosSXIn0QkUqhGhvVYvTq67mQQRa++P1rTX1eBJIcj LJyhu9e/2PG2NQtaHPWNSr2cDxYXZv58ASfkDYcfobRKqkvvXfeYz9VDhz1RtboX/QMe vWCPFvC0qJ4MZuHl5kidHiKTIlyM1Z69fgRSspttnUkZgIKg4husI76MfBV2bD90eURs 4SxJkp1pe487JTuo+p1pJXHmM7zrN/irtpSyz7u+DeATGLRx82bmcAWZZtskCDqBDSGq oq3w== X-Gm-Message-State: AOJu0Yz7+khfuDGs6pX2smrHCNc852Hm1HB8Y1dMJn0bgXrnda8D+aAh 03a6VDGD8SaI2bmQAqcW2hqbjgollXEgsqMmk4E1FQ== X-Google-Smtp-Source: AGHT+IF5ffgEDdQH0/4+nFKZRMdQuymVOLwrHx8J7OhnvHdITv7YUyzierTNgqzJ+mIOieY1/qKKwA== X-Received: by 2002:a05:6000:236:b0:32f:7db1:22f1 with SMTP id l22-20020a056000023600b0032f7db122f1mr5879937wrz.60.1700560822349; Tue, 21 Nov 2023 02:00:22 -0800 (PST) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id v6-20020adfedc6000000b00326dd5486dcsm13858839wro.107.2023.11.21.02.00.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 21 Nov 2023 02:00:21 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [COMMITTED] ada: Deep delta aggregates Date: Tue, 21 Nov 2023 11:00:20 +0100 Message-ID: <20231121100020.1964112-1-poulhies@adacore.com> X-Mailer: git-send-email 2.42.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org From: Steve Baird Add support for "deep" delta aggregates, a GNAT-defined language extension conditionally enabled via the -gnatX0 switch. In a deep delta aggregate, a delta choice may specify a subcomponent (as opposed to just a component). gcc/ada/ * par.adb: Add new Boolean variable Inside_Delta_Aggregate. * par-ch4.adb (P_Simple_Expression): Add support for a deep delta aggregate choice. We turn a sequence of selectors into a peculiar tree. We build a component (Indexed or Selected) whose prefix is another such component, etc. The leftmost prefix at the bottom of the tree has a "name" which is the first selector, without any further prefix. For something like "with delta (1)(2) => 3" where the type of the aggregate is an array of arrays of integers, we'll build an N_Indexed_Component whose prefix is an integer literal 1. This is consistent with the trees built for "regular" (Ada-defined) delta aggregates. * sem_aggr.adb (Is_Deep_Choice, Is_Root_Prefix_Of_Deep_Choice): New queries. (Resolve_Deep_Delta_Assoc): new procedure. (Resolve_Delta_Array_Aggregate): call Resolve_Deep_Delta_Assoc in deep case. (Resolve_Delta_Record_Aggregate): call Resolve_Deep_Delta_Assoc in deep case. (Get_Component_Type): new function replaces old Get_Component function. * sem_aggr.ads (Is_Deep_Choice, Is_Root_Prefix_Of_Deep_Choice): New queries. * exp_aggr.adb (Expand_Delta_Array_Aggregate): add nested function Make_Array_Delta_Assignment_LHS; call it instead of Make_Indexed_Component. (Expand_Delta_Record_Aggregate): add nested function Make_Record_Delta_Assignment_LHS; call it instead of Make_Selected_Component. * exp_spark.adb (Expand_SPARK_Delta_Or_Update): Insert range checks for indexes in deep delta aggregates. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 108 ++++++++++++++-- gcc/ada/exp_spark.adb | 53 +++++++- gcc/ada/par-ch4.adb | 120 +++++++++++++++++- gcc/ada/par.adb | 5 + gcc/ada/sem_aggr.adb | 288 +++++++++++++++++++++++++++++++++++------- gcc/ada/sem_aggr.ads | 14 +- 6 files changed, 522 insertions(+), 66 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 319254dfd63..a6a54e892e2 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5243,7 +5243,7 @@ package body Exp_Aggr is -- The bounds of the aggregate for this dimension Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim); - -- The index type for this dimension.xxx + -- The index type for this dimension. Cond : Node_Id; Assoc : Node_Id; @@ -7344,6 +7344,12 @@ package body Exp_Aggr is -- choices that are ranges, subtype indications, subtype names, and -- iterated component associations. + function Make_Array_Delta_Assignment_LHS + (Choice : Node_Id; Temp : Entity_Id) return Node_Id; + -- Generate the LHS for the assignment associated with one + -- component association. This can be more complex than just an + -- indexed component in the case of a deep delta aggregate. + ------------------- -- Generate_Loop -- ------------------- @@ -7380,6 +7386,60 @@ package body Exp_Aggr is End_Label => Empty); end Generate_Loop; + function Make_Array_Delta_Assignment_LHS + (Choice : Node_Id; Temp : Entity_Id) return Node_Id + is + function Make_Delta_Choice_LHS + (Choice : Node_Id; + Deep_Choice : Boolean) return Node_Id; + -- Recursively (but recursion only in deep delta aggregate case) + -- build up the LHS by successively applying selectors. + + --------------------------- + -- Make_Delta_Choice_LHS -- + --------------------------- + + function Make_Delta_Choice_LHS + (Choice : Node_Id; + Deep_Choice : Boolean) return Node_Id + is + begin + if not Deep_Choice + or else Is_Root_Prefix_Of_Deep_Choice (Choice) + then + return Make_Indexed_Component (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Expressions => New_List (New_Copy_Tree (Choice))); + + else + -- a deep delta aggregate choice + pragma Assert (All_Extensions_Allowed); + + declare + -- recursively get name for prefix + LHS_Prefix : constant Node_Id + := Make_Delta_Choice_LHS (Prefix (Choice), Deep_Choice); + begin + if Nkind (Choice) = N_Indexed_Component then + return Make_Indexed_Component (Sloc (Choice), + Prefix => LHS_Prefix, + Expressions => New_Copy_List (Expressions (Choice))); + else + return Make_Selected_Component (Sloc (Choice), + Prefix => LHS_Prefix, + Selector_Name => + Make_Identifier + (Sloc (Choice), + Chars (Selector_Name (Choice)))); + end if; + end; + end if; + end Make_Delta_Choice_LHS; + begin + return Make_Delta_Choice_LHS + (Choice, Is_Deep_Choice (Choice, Etype (N))); + end Make_Array_Delta_Assignment_LHS; + -- Local variables Choice : Node_Id; @@ -7416,9 +7476,7 @@ package body Exp_Aggr is Append_To (Deltas, Make_Assignment_Statement (Sloc (Choice), Name => - Make_Indexed_Component (Sloc (Choice), - Prefix => New_Occurrence_Of (Temp, Loc), - Expressions => New_List (New_Copy_Tree (Choice))), + Make_Array_Delta_Assignment_LHS (Choice, Temp), Expression => New_Copy_Tree (Expression (Assoc)))); end if; @@ -7443,6 +7501,43 @@ package body Exp_Aggr is Assoc : Node_Id; Choice : Node_Id; + function Make_Record_Delta_Assignment_LHS + (Selector : Node_Id) return Node_Id; + -- Generate the LHS for an assignment to a component (or subcomponent + -- if -gnatX specified) of the result object. + + -------------------------------------- + -- Make_Record_Delta_Assignment_LHS -- + -------------------------------------- + + function Make_Record_Delta_Assignment_LHS + (Selector : Node_Id) return Node_Id + is + begin + if Nkind (Selector) = N_Selected_Component then + -- a deep delta aggregate, requires -gnatX0 + return + Make_Selected_Component + (Sloc (Choice), + Prefix => Make_Record_Delta_Assignment_LHS + (Prefix (Selector)), + Selector_Name => + Make_Identifier (Loc, Chars (Selector_Name (Selector)))); + elsif Nkind (Selector) = N_Indexed_Component then + -- a deep delta aggregate, requires -gnatX0 + return + Make_Indexed_Component + (Sloc (Choice), + Prefix => Make_Record_Delta_Assignment_LHS + (Prefix (Selector)), + Expressions => Expressions (Selector)); + else + return Make_Selected_Component + (Sloc (Choice), + Prefix => New_Occurrence_Of (Temp, Loc), + Selector_Name => Make_Identifier (Loc, Chars (Selector))); + end if; + end Make_Record_Delta_Assignment_LHS; begin Assoc := First (Component_Associations (N)); @@ -7451,10 +7546,7 @@ package body Exp_Aggr is while Present (Choice) loop Append_To (Deltas, Make_Assignment_Statement (Sloc (Choice), - Name => - Make_Selected_Component (Sloc (Choice), - Prefix => New_Occurrence_Of (Temp, Loc), - Selector_Name => Make_Identifier (Loc, Chars (Choice))), + Name => Make_Record_Delta_Assignment_LHS (Choice), Expression => New_Copy_Tree (Expression (Assoc)))); Next (Choice); end loop; diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index c344dc1e706..c19aa201bde 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -43,6 +43,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; @@ -186,15 +187,47 @@ package body Exp_SPARK is (Typ : Entity_Id; Aggr : Node_Id) is + procedure Apply_Range_Checks (Choice : Node_Id); + -- Apply range checks on indexes from a deep choice + + ------------------------ + -- Apply_Range_Checks -- + ------------------------ + + procedure Apply_Range_Checks (Choice : Node_Id) is + Pref : Node_Id := Choice; + Index : N_Subexpr_Id; + begin + loop + if Nkind (Pref) = N_Indexed_Component then + Index := First (Expressions (Choice)); + Apply_Scalar_Range_Check (Index, Etype (Index)); + + elsif Is_Array_Type (Typ) + and then Is_Root_Prefix_Of_Deep_Choice (Pref) + then + Index := Pref; + Apply_Scalar_Range_Check (Index, Etype (Index)); + end if; + + exit when Is_Root_Prefix_Of_Deep_Choice (Pref); + + Pref := Prefix (Pref); + end loop; + end Apply_Range_Checks; + + -- Local variables + Assoc : Node_Id; Comp : Node_Id; - Comp_Id : Entity_Id; Comp_Type : Entity_Id; Expr : Node_Id; Index : Node_Id; Index_Typ : Entity_Id; New_Assoc : Node_Id; + -- Start of processing for Expand_SPARK_Delta_Or_Update + begin -- Apply scalar range checks on the updated components, if needed @@ -277,6 +310,9 @@ package body Exp_SPARK is if Nkind (Index) in N_Range | N_Subtype_Indication then null; + elsif Is_Deep_Choice (Index, Typ) then + Apply_Range_Checks (Index); + -- Otherwise the index denotes a single expression where -- range checks need to be applied or a subtype name -- (without range constraints) where applying checks is @@ -346,15 +382,16 @@ package body Exp_SPARK is Comp := First (Choices (Assoc)); while Present (Comp) loop - Comp_Id := Entity (Comp); - Comp_Type := Etype (Comp_Id); + if Is_Deep_Choice (Comp, Typ) then + Comp_Type := Etype (Comp); + else + Comp_Type := Etype (Entity (Comp)); + end if; New_Assoc := Make_Component_Association (Sloc => Sloc (Assoc), - Choices => - New_List - (New_Occurrence_Of (Comp_Id, Sloc (Comp))), + Choices => New_List (New_Copy_Tree (Comp)), Expression => New_Copy_Tree (Expr)); -- New association must be attached to the aggregate before we @@ -364,6 +401,10 @@ package body Exp_SPARK is Analyze_And_Resolve (Expression (New_Assoc), Comp_Type); + if Is_Deep_Choice (Comp, Typ) then + Apply_Range_Checks (First (Choices (New_Assoc))); + end if; + if Is_Scalar_Type (Comp_Type) then Apply_Scalar_Range_Check (Expression (New_Assoc), Comp_Type); diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 52f2b02361a..2ff6e001f39 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1393,6 +1393,8 @@ package body Ch4 is Start_Token : constant Token_Type := Token; -- Used to prevent mismatches (...] and [...) + Saved_Delta_Aggregate_Flag : constant Boolean := Inside_Delta_Aggregate; + -- Start of processing for P_Aggregate_Or_Paren_Expr begin @@ -1497,6 +1499,7 @@ package body Ch4 is Scan; -- past WITH if Token = Tok_Delta then Scan; -- past DELTA + Inside_Delta_Aggregate := True; Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc); Set_Expression (Aggregate_Node, Expr_Node); Expr_Node := Empty; @@ -1707,6 +1710,16 @@ package body Ch4 is end if; Set_Component_Associations (Aggregate_Node, Assoc_List); + + -- Inside_Delta_Aggregate is only tested if Serious_Errors = 0, so + -- it is ok if we fail to restore the saved I_D_A value in an error + -- path. In particular, it is ok that we do not restore it if + -- Error_Resync is propagated. Earlier return statements (which return + -- without restoring the saved I_D_A value) should either be in error + -- paths or in paths where I_D_A could not have been modified. + + Inside_Delta_Aggregate := Saved_Delta_Aggregate_Flag; + return Aggregate_Node; end P_Aggregate_Or_Paren_Expr; @@ -2519,6 +2532,109 @@ package body Ch4 is Expr_Form := EF_Simple; end if; + -- If all extensions are enabled and we have a deep delta aggregate + -- whose type is an array type with an element type that is a + -- record type, then we can encounter legal things like + -- with delta (Some_Index_Expression).Some_Component + -- where a parenthesized expression precedes a dot. + -- Similarly, if the element type is an array type then we can see + -- with delta (Some_Index_Expression)(Another_Index_Expression) + -- where a parenthesized expression precedes a left parenthesis. + + if Token in Tok_Dot | Tok_Left_Paren + and then Prev_Token = Tok_Right_Paren + and then Serious_Errors_Detected = 0 + and then Inside_Delta_Aggregate + and then All_Extensions_Allowed + then + if Token = Tok_Dot then + Node2 := New_Node (N_Selected_Component, Token_Ptr); + Scan; -- past dot + declare + Tail : constant Node_Id := P_Simple_Expression; + -- remaining selectors occurring after the dot + + Rover : Node_Id := Tail; + Prev : Node_Id := Empty; + begin + -- If Tail already has a prefix, then we want to prepend + -- Node1 onto that prefix and then return Tail. + -- Otherwise, Tail should simply be an identifier so + -- we want to build a Selected_Component with Tail as the + -- selector name and return that. + + Set_Prefix (Node2, Node1); + + while Nkind (Rover) + in N_Indexed_Component | N_Selected_Component loop + Prev := Rover; + Rover := Prefix (Rover); + end loop; + + case Nkind (Prev) is + when N_Selected_Component | N_Indexed_Component => + -- We've scanned a dot, so an identifier should follow + if Nkind (Prefix (Prev)) = N_Identifier then + Set_Selector_Name (Node2, Prefix (Prev)); + Set_Prefix (Prev, Node2); + return Tail; + end if; + + when N_Empty => + -- We've scanned a dot, so an identifier should follow + if Nkind (Tail) = N_Identifier then + Set_Selector_Name (Node2, Tail); + return Node2; + end if; + + when others => + null; + end case; + + -- fall through to error case + end; + else + Node2 := New_Node (N_Indexed_Component, Token_Ptr); + declare + Tail : constant Node_Id := P_Simple_Expression; + -- remaining selectors + + Rover : Node_Id := Tail; + Prev : Node_Id := Empty; + begin + -- If Tail already has a prefix, then we want to prepend + -- Node1 onto that prefix and then return Tail. + -- Otherwise, Tail should be an index expression and + -- we want to build an Indexed_Component with Tail as the + -- index value and return that. + + Set_Prefix (Node2, Node1); + + while Nkind (Rover) + in N_Indexed_Component | N_Selected_Component loop + Prev := Rover; + Rover := Prefix (Rover); + end loop; + + case Nkind (Prev) is + when N_Selected_Component | N_Indexed_Component => + Set_Expressions (Node2, New_List (Prefix (Prev))); + Set_Prefix (Prev, Node2); + return Tail; + + when N_Empty => + Set_Expressions (Node2, New_List (Tail)); + return Node2; + + when others => + null; + end case; + + -- fall through to error case + end; + end if; + end if; + -- Come here at end of simple expression, where we do a couple of -- special checks to improve error recovery. @@ -2529,8 +2645,8 @@ package body Ch4 is if Token = Tok_Dot then Error_Msg_SC ("prefix for selection is not a name"); - -- If qualified expression, comment and continue, otherwise something - -- is pretty nasty so do an Error_Resync call. + -- If qualified expression, comment and continue, otherwise + -- something is pretty nasty so do an Error_Resync call. if Ada_Version < Ada_2012 and then Nkind (Node1) = N_Qualified_Expression diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 5206899b261..180ec08561c 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -76,6 +76,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- Variable used to save values of config switches while we parse the -- new unit, to be restored on exit for proper recursive behavior. + Inside_Delta_Aggregate : Boolean := False; + -- True within a delta aggregate (but only after the "delta" token has + -- been scanned). Used to distinguish syntax errors from syntactically + -- correct "deep" delta aggregates (enabled via -gnatX0). + -------------------- -- Error Recovery -- -------------------- diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 36db7987d91..c1d25404ae4 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -27,7 +27,6 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; -with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Elists; use Elists; with Errout; use Errout; @@ -423,6 +422,9 @@ package body Sem_Aggr is procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Deep_Delta_Assoc (N : Node_Id; Typ : Entity_Id); + -- Resolve the names/expressions in a component association for + -- a deep delta aggregate. Typ is the type of the enclosing object. ------------------------ -- Array_Aggr_Subtype -- @@ -759,6 +761,28 @@ package body Sem_Aggr is end if; end Check_Expr_OK_In_Limited_Aggregate; + -------------------- + -- Is_Deep_Choice -- + -------------------- + + function Is_Deep_Choice + (Choice : Node_Id; + Aggr_Type : Type_Kind_Id) return Boolean + is + Pref : Node_Id := Choice; + begin + while not Is_Root_Prefix_Of_Deep_Choice (Pref) loop + Pref := Prefix (Pref); + end loop; + + if Is_Array_Type (Aggr_Type) then + return Paren_Count (Pref) > 0 + and then Pref /= Choice; + else + return Pref /= Choice; + end if; + end Is_Deep_Choice; + ------------------------- -- Is_Others_Aggregate -- ------------------------- @@ -771,6 +795,17 @@ package body Sem_Aggr is and then Nkind (First (Choice_List (First (Assoc)))) = N_Others_Choice; end Is_Others_Aggregate; + ----------------------------------- + -- Is_Root_Prefix_Of_Deep_Choice -- + ----------------------------------- + + function Is_Root_Prefix_Of_Deep_Choice (Pref : Node_Id) return Boolean is + begin + return Paren_Count (Pref) > 0 + or else Nkind (Pref) not in N_Indexed_Component + | N_Selected_Component; + end Is_Root_Prefix_Of_Deep_Choice; + ------------------------- -- Is_Single_Aggregate -- ------------------------- @@ -3713,31 +3748,38 @@ package body Sem_Aggr is else Choice := First (Choice_List (Assoc)); while Present (Choice) loop - Analyze (Choice); + if Is_Deep_Choice (Choice, Typ) then + pragma Assert (All_Extensions_Allowed); - if Nkind (Choice) = N_Others_Choice then - Error_Msg_N - ("OTHERS not allowed in delta aggregate", Choice); + -- a deep delta aggregate + Resolve_Deep_Delta_Assoc (Assoc, Typ); + else + Analyze (Choice); - elsif Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - -- Choice covers a range of values + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("OTHERS not allowed in delta aggregate", Choice); - if Base_Type (Entity (Choice)) /= - Base_Type (Index_Type) + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) then - Error_Msg_NE - ("choice does not match index type of &", - Choice, Typ); - end if; + -- Choice covers a range of values - elsif Nkind (Choice) = N_Subtype_Indication then - Resolve_Discrete_Subtype_Indication - (Choice, Base_Type (Index_Type)); + if Base_Type (Entity (Choice)) /= + Base_Type (Index_Type) + then + Error_Msg_NE + ("choice does not match index type of &", + Choice, Typ); + end if; - else - Resolve (Choice, Index_Type); + elsif Nkind (Choice) = N_Subtype_Indication then + Resolve_Discrete_Subtype_Indication + (Choice, Base_Type (Index_Type)); + + else + Resolve (Choice, Index_Type); + end if; end if; Next (Choice); @@ -3773,14 +3815,15 @@ package body Sem_Aggr is Comp_Ref : Entity_Id := Empty; -- init to avoid warning Variant : Node_Id; - procedure Check_Variant (Id : Entity_Id); + procedure Check_Variant (Id : Node_Id); -- If a given component of the delta aggregate appears in a variant -- part, verify that it is within the same variant as that of previous -- specified variant components of the delta. - function Get_Component (Nam : Node_Id) return Entity_Id; - -- Locate component with a given name and return it. If none found then - -- report error and return Empty. + function Get_Component_Type + (Selector : Node_Id; Enclosing_Type : Entity_Id) return Entity_Id; + -- Locate component with a given name and return its type. + -- If none found then report error and return Empty. function Nested_In (V1 : Node_Id; V2 : Node_Id) return Boolean; -- Determine whether variant V1 is within variant V2 @@ -3792,7 +3835,7 @@ package body Sem_Aggr is -- Check_Variant -- -------------------- - procedure Check_Variant (Id : Entity_Id) is + procedure Check_Variant (Id : Node_Id) is Comp : Entity_Id; Comp_Variant : Node_Id; @@ -3843,30 +3886,80 @@ package body Sem_Aggr is end if; end Check_Variant; - ------------------- - -- Get_Component -- - ------------------- + ------------------------ + -- Get_Component_Type -- + ------------------------ - function Get_Component (Nam : Node_Id) return Entity_Id is + function Get_Component_Type + (Selector : Node_Id; Enclosing_Type : Entity_Id) return Entity_Id + is Comp : Entity_Id; - begin - Comp := First_Entity (Typ); + case Nkind (Selector) is + when N_Selected_Component | N_Indexed_Component => + -- a deep delta aggregate choice + + declare + Prefix_Type : constant Entity_Id := + Get_Component_Type (Prefix (Selector), Enclosing_Type); + begin + if not Present (Prefix_Type) then + pragma Assert (Serious_Errors_Detected > 0); + return Empty; + end if; + + -- Set the type of the prefix for GNATprove + + Set_Etype (Prefix (Selector), Prefix_Type); + + if Nkind (Selector) = N_Selected_Component then + return Get_Component_Type + (Selector_Name (Selector), + Enclosing_Type => Prefix_Type); + elsif not Is_Array_Type (Prefix_Type) then + Error_Msg_NE + ("type& is not an array type", + Selector, Prefix_Type); + elsif Number_Dimensions (Prefix_Type) /= 1 then + Error_Msg_NE + ("array type& not one-dimensional", + Selector, Prefix_Type); + elsif List_Length (Expressions (Selector)) /= 1 then + Error_Msg_NE + ("wrong number of indices for array type&", + Selector, Prefix_Type); + else + Analyze_And_Resolve + (First (Expressions (Selector)), + Etype (First_Index (Prefix_Type))); + return Component_Type (Prefix_Type); + end if; + end; + + when others => + null; + end case; + + Comp := First_Entity (Enclosing_Type); while Present (Comp) loop - if Chars (Comp) = Chars (Nam) then + if Chars (Comp) = Chars (Selector) then if Ekind (Comp) = E_Discriminant then - Error_Msg_N ("delta cannot apply to discriminant", Nam); + Error_Msg_N ("delta cannot apply to discriminant", Selector); end if; - return Comp; + Set_Entity (Selector, Comp); + Set_Etype (Selector, Etype (Comp)); + + return Etype (Comp); end if; Next_Entity (Comp); end loop; - Error_Msg_NE ("type& has no component with this name", Nam, Typ); + Error_Msg_NE + ("type& has no component with this name", Selector, Enclosing_Type); return Empty; - end Get_Component; + end Get_Component_Type; --------------- -- Nested_In -- @@ -3911,10 +4004,10 @@ package body Sem_Aggr is Deltas : constant List_Id := Component_Associations (N); - Assoc : Node_Id; - Choice : Node_Id; - Comp : Entity_Id; - Comp_Type : Entity_Id := Empty; -- init to avoid warning + Assoc : Node_Id; + Choice : Node_Id; + Comp_Type : Entity_Id := Empty; -- init to avoid warning + Deep_Choice : Boolean; -- Start of processing for Resolve_Delta_Record_Aggregate @@ -3925,19 +4018,27 @@ package body Sem_Aggr is while Present (Assoc) loop Choice := First (Choice_List (Assoc)); while Present (Choice) loop - Comp := Get_Component (Choice); + Deep_Choice := Nkind (Choice) /= N_Identifier; + if Deep_Choice then + Error_Msg_GNAT_Extension + ("deep delta aggregate", Sloc (Choice)); + end if; - if Present (Comp) then - Check_Variant (Choice); + Comp_Type := Get_Component_Type + (Selector => Choice, Enclosing_Type => Typ); - Comp_Type := Etype (Comp); + -- Set the type of the choice for GNATprove - -- Decorate the component reference by setting its entity and - -- type, as otherwise backends like GNATprove would have to - -- rediscover this information by themselves. + if Deep_Choice then + Set_Etype (Choice, Comp_Type); + end if; - Set_Entity (Choice, Comp); - Set_Etype (Choice, Comp_Type); + if Present (Comp_Type) then + if not Deep_Choice then + -- ??? Not clear yet how RM 4.3.1(17.7) applies to a + -- deep delta aggregate. + Check_Variant (Choice); + end if; else Comp_Type := Any_Type; end if; @@ -3973,6 +4074,95 @@ package body Sem_Aggr is end loop; end Resolve_Delta_Record_Aggregate; + ------------------------------ + -- Resolve_Deep_Delta_Assoc -- + ------------------------------ + + procedure Resolve_Deep_Delta_Assoc (N : Node_Id; Typ : Entity_Id) is + Choice : constant Node_Id := First (Choice_List (N)); + Enclosing_Type : Entity_Id := Typ; + + procedure Resolve_Choice_Prefix + (Choice_Prefix : Node_Id; Enclosing_Type : in out Entity_Id); + -- Recursively analyze selectors. Enclosing_Type is set to + -- type of the last component. + + --------------------------- + -- Resolve_Choice_Prefix -- + --------------------------- + + procedure Resolve_Choice_Prefix + (Choice_Prefix : Node_Id; Enclosing_Type : in out Entity_Id) + is + Selector : Node_Id := Choice_Prefix; + begin + if not Is_Root_Prefix_Of_Deep_Choice (Choice_Prefix) then + Resolve_Choice_Prefix (Prefix (Choice_Prefix), Enclosing_Type); + + if Nkind (Choice_Prefix) = N_Selected_Component then + Selector := Selector_Name (Choice_Prefix); + else + pragma Assert (Nkind (Choice_Prefix) = N_Indexed_Component); + Selector := First (Expressions (Choice_Prefix)); + end if; + end if; + + if Is_Array_Type (Enclosing_Type) then + Analyze_And_Resolve (Selector, + Etype (First_Index (Enclosing_Type))); + Enclosing_Type := Component_Type (Enclosing_Type); + else + declare + Comp : Entity_Id := First_Entity (Enclosing_Type); + Found : Boolean := False; + begin + while Present (Comp) and not Found loop + if Chars (Comp) = Chars (Selector) then + if Ekind (Comp) = E_Discriminant then + Error_Msg_N ("delta cannot apply to discriminant", + Selector); + end if; + Found := True; + Set_Entity (Selector, Comp); + Set_Etype (Selector, Etype (Comp)); + Set_Analyzed (Selector); + Enclosing_Type := Etype (Comp); + else + Next_Entity (Comp); + end if; + end loop; + if not Found then + Error_Msg_NE + ("type& has no component with this name", + Selector, Enclosing_Type); + end if; + end; + end if; + + -- Set the type of the prefix for GNATprove, except for the root + -- prefix, whose type is already the expected one for a record + -- delta aggregate, or the type of the array index for an + -- array delta aggregate (the only case here really since + -- Resolve_Deep_Delta_Assoc is only called for array delta + -- aggregates). + + if Selector /= Choice_Prefix then + Set_Etype (Choice_Prefix, Enclosing_Type); + end if; + end Resolve_Choice_Prefix; + begin + declare + Unimplemented : exception; -- TEMPORARY + begin + if Present (Next (Choice)) then + raise Unimplemented; + end if; + end; + + Resolve_Choice_Prefix (Choice, Enclosing_Type); + Analyze_And_Resolve (Expression (N), Enclosing_Type); + end Resolve_Deep_Delta_Assoc; + --------------------------------- -- Resolve_Extension_Aggregate -- --------------------------------- diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads index 46d28aee059..386a16161b2 100644 --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -26,7 +26,8 @@ -- This package contains the resolution code for aggregates. It is logically -- part of Sem_Res, but is split off since the aggregate code is so complex. -with Types; use Types; +with Einfo.Entities; use Einfo.Entities; +with Types; use Types; package Sem_Aggr is @@ -50,4 +51,15 @@ package Sem_Aggr is function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean; -- Returns True for the high bound of a null array aggregate. + function Is_Deep_Choice + (Choice : Node_Id; + Aggr_Type : Type_Kind_Id) return Boolean; + -- Returns whether Choice from a delta aggregate of type Aggr_Type is a + -- deep choice. + + function Is_Root_Prefix_Of_Deep_Choice (Pref : Node_Id) return Boolean; + -- Returns whether prefix Pref of a deep choice is its root prefix. Except + -- for its use in Is_Deep_Choice, this function should only be called on + -- prefixes of a deep choice as identified by Is_Deep_Choice. + end Sem_Aggr;