From patchwork Thu May 19 14:16:01 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 54213 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 78B04383F843 for ; Thu, 19 May 2022 14:23:20 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 78B04383F843 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1652970200; bh=9dzyweMdUoFYfGnefFl5Kg36RePFMYoOLcz9YKJ6fMg=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=Gai8yDxzYLF589ANzwfOitnbd4Y8l1UOYMUg5ESacW+xRGnM5K84I34ve0aBUqO4d RH6Igfk4HHorAHl7SioURyg4jAubVi8FDgDs/BrNJM6uGMKNdd+PRmzNClV3Lm4Fnw 9UJRXDVprtwgNZrOopnzujNDKn+oblZ+RyhPfq+4= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x435.google.com (mail-wr1-x435.google.com [IPv6:2a00:1450:4864:20::435]) by sourceware.org (Postfix) with ESMTPS id B06AB383D83B for ; Thu, 19 May 2022 14:16:02 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B06AB383D83B Received: by mail-wr1-x435.google.com with SMTP id j25so7361253wrc.9 for ; Thu, 19 May 2022 07:16:02 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=9dzyweMdUoFYfGnefFl5Kg36RePFMYoOLcz9YKJ6fMg=; b=izFjnmtcaF3bKgQbAMIY/yp8kjOZ4+mE06bgzDHi5RhYN3ZeysD1QRLSa4Uu4QSB+v qYTmhTUsn4nj/eDG8bel7JaZaCCE86H6S6i1+51d6FlVpbuZKgGRDUix2dmHOQQdgbyX 9A3qA97mEUQBHpBP152f5NLulEllBsmwS0jD9B4ovJ1ReCcPFGfqkfZg8NBn0/k2S9Js DDu+36y4YsOpJZqXmW5YR78CwvtRzzgLSo20PqhrVD6H1INNWHnezXGuEOUIZY3mHMxr 7lWwoSLVhfYjT9gOLcaL9Vlwsh3VO9p3EFZ9VogvlwRH7abXCXZdj4P5tp7nW5nc7nOG q5CA== X-Gm-Message-State: AOAM532+kGcNfJzhPhpxBYEpjPuVfrBU5gMDCw3Wdsmvmuy0TPoa+UYL uMI8I+LzQcQtqqzFeLpBEr21dkHkCwj6eg== X-Google-Smtp-Source: ABdhPJxcBwtpOwBBR4n4C5ULAq8KKW8TDGf4TYKtA4MKfjbqKXfr0mMAtGFmGiyV/N9x55cF0+ZdSQ== X-Received: by 2002:a05:6000:717:b0:20e:6160:39dd with SMTP id bs23-20020a056000071700b0020e616039ddmr4288582wrb.331.1652969762213; Thu, 19 May 2022 07:16:02 -0700 (PDT) Received: from adacore.com ([45.147.211.82]) by smtp.gmail.com with ESMTPSA id l12-20020adfc78c000000b0020c5253d90asm5383273wrg.86.2022.05.19.07.16.01 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 19 May 2022 07:16:01 -0700 (PDT) Date: Thu, 19 May 2022 14:16:01 +0000 To: gcc-patches@gcc.gnu.org Subject: [Ada] Support Ada 2022 null array aggregates Message-ID: <20220519141601.GA3723184@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-12.8 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Pierre-Marie de Rodat via Gcc-patches From: Pierre-Marie de Rodat Reply-To: Pierre-Marie de Rodat Cc: Ed Schonberg Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Add support for Ada 2022's "[]" null array aggregates (thanks to Ed Schonberg for producing most of this patch). Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * erroutc.ads: Fix a single-character typo in a comment. * exp_aggr.adb: Fix a single-character typo in a comment. Replace several pairs of calls to Low_Bound and High_Bound (which do not handle an identifier that denotes a scalar subtype) with corresponding calls to Get_Index_Bounds (which does handle that case). * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Set the Component_Associations attribute of a null array aggregate to New_List. * sem_aggr.ads: New visible function Is_Null_Array_Aggregate_High_Bound. * sem_aggr.adb (Is_Null_Array_Aggregate_High_Bound, Is_Null_Aggregate, Resolve_Null_Array_Aggregate): New functions. (Resolve_Aggregate): Recognize null array aggregates (using Is_Null_Aggregate) and, when one is recognized, resolve it (using Resolve_Null_Array_Aggregate). Avoid calling Array_Aggr_Subtype for a null array aggregate; the needed subtype is built in Resolve_Null_Array_Aggregate. Do not incorrectly flag a null aggregate (after it is transformed by expansion) as being both positional and named. * sem_attr.adb (Eval_Attribute): Special treatment for null array aggregate high bounds to avoid incorrectly flagging something like Integer'Pred (Integer'First) as an illegal static expression. * sem_eval.adb (Out_Of_Range): Special treatment for null array aggregate high bounds to avoid incorrectly flagging something like Integer'Pred (Integer'First) as an illegal static expression. diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -465,7 +465,7 @@ package Erroutc is -- Tests if message buffer ends with given string preceded by a space procedure Buffer_Remove (C : Character); - -- Remove given character fron end of buffer if it is present + -- Remove given character from end of buffer if it is present procedure Buffer_Remove (S : String); -- Removes given string from end of buffer if it is present at end of diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2280,8 +2280,10 @@ package body Exp_Aggr is New_Code : constant List_Id := New_List; - Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); - Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); + Aggr_Bounds : constant Range_Nodes := + Get_Index_Bounds (Aggregate_Bounds (N)); + Aggr_L : Node_Id renames Aggr_Bounds.First; + Aggr_H : Node_Id renames Aggr_Bounds.Last; -- The aggregate bounds of this specific subaggregate. Note that if the -- code generated by Build_Array_Aggr_Code is executed then these bounds -- are OK. Otherwise a Constraint_Error would have been raised. @@ -2577,7 +2579,7 @@ package body Exp_Aggr is -- If Typ is derived, and constrains discriminants of the parent type, -- these discriminants are not components of the aggregate, and must be -- initialized. The assignments are appended to List. The same is done - -- if Typ derives fron an already constrained subtype of a discriminated + -- if Typ derives from an already constrained subtype of a discriminated -- parent type. procedure Init_Stored_Discriminants; @@ -5226,6 +5228,11 @@ package body Exp_Aggr is Others_Present := False; if Present (Component_Associations (N)) then + if Is_Empty_List (Component_Associations (N)) then + -- an expanded null array aggregate + return False; + end if; + declare Assoc : Node_Id; Choice : Node_Id; @@ -5914,8 +5921,10 @@ package body Exp_Aggr is ---------------------------- procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is - Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr)); - Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr)); + Sub_Bounds : constant Range_Nodes + := Get_Index_Bounds (Aggregate_Bounds (Sub_Aggr)); + Sub_Lo : Node_Id renames Sub_Bounds.First; + Sub_Hi : Node_Id renames Sub_Bounds.Last; -- The bounds of this specific subaggregate Aggr_Lo : constant Node_Id := Aggr_Low (Dim); @@ -6019,7 +6028,9 @@ package body Exp_Aggr is if Present (Component_Associations (Sub_Aggr)) then Assoc := Last (Component_Associations (Sub_Aggr)); - if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then + if Present (Assoc) + and then Nkind (First (Choice_List (Assoc))) = N_Others_Choice + then Others_Present (Dim) := True; -- An others_clause may be superfluous if previous components @@ -6107,7 +6118,10 @@ package body Exp_Aggr is elsif Present (Expressions (Sub_Aggr)) and then Present (Component_Associations (Sub_Aggr)) then - Need_To_Check := True; + Need_To_Check := + not (Is_Empty_List (Expressions (Sub_Aggr)) + and then Is_Empty_List + (Component_Associations (Sub_Aggr))); elsif Present (Component_Associations (Sub_Aggr)) then Assoc := Last (Component_Associations (Sub_Aggr)); @@ -6666,8 +6680,8 @@ package body Exp_Aggr is -- Save the low and high bounds of the aggregate index as well as -- the index type for later use in checks (b) and (c) below. - Aggr_Low (J) := Low_Bound (Aggr_Index_Range); - Aggr_High (J) := High_Bound (Aggr_Index_Range); + Get_Index_Bounds + (Aggr_Index_Range, L => Aggr_Low (J), H => Aggr_High (J)); Aggr_Index_Typ (J) := Etype (Index_Constraint); @@ -7180,7 +7194,8 @@ package body Exp_Aggr is MX : constant := 80; begin - if Nkind (First (Choice_List (CA))) = N_Others_Choice + if Present (CA) + and then Nkind (First (Choice_List (CA))) = N_Others_Choice and then Nkind (Expression (CA)) = N_Character_Literal and then No (Expressions (N)) then diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1405,6 +1405,7 @@ package body Ch4 is Scan; -- past ] Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); Set_Expressions (Aggregate_Node, New_List); + Set_Component_Associations (Aggregate_Node, New_List); Set_Is_Homogeneous_Aggregate (Aggregate_Node); return Aggregate_Node; end if; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -404,11 +404,25 @@ package body Sem_Aggr is -- The bounds of the aggregate itype are cooked up to look reasonable -- (in this particular case the bounds will be 1 .. 2). + function Is_Null_Aggregate (N : Node_Id) return Boolean; + -- Returns True for a "[]" aggregate (an Ada 2022 feature), even after + -- it has been transformed by expansion. Returns False otherwise. + procedure Make_String_Into_Aggregate (N : Node_Id); -- A string literal can appear in a context in which a one dimensional -- array of characters is expected. This procedure simply rewrites the -- string as an aggregate, prior to resolution. + function Resolve_Null_Array_Aggregate (N : Node_Id) return Boolean; + -- For the Ada 2022 construct, build a subtype with a null range for each + -- dimension, using the bounds from the context subtype (if the subtype + -- is constrained). If the subtype is unconstrained, then the bounds + -- are determined in much the same way as the bounds for a null string + -- literal with no applicable index constraint. + -- Emit a check that the bounds for each dimension define a null + -- range; no check is emitted if it is statically known that the + -- check would succeed. + --------------------------------- -- Delta aggregate processing -- --------------------------------- @@ -754,6 +768,34 @@ package body Sem_Aggr is and then No (Next (First (Choice_List (First (Assoc))))); end Is_Single_Aggregate; + ----------------------- + -- Is_Null_Aggregate -- + ----------------------- + + function Is_Null_Aggregate (N : Node_Id) return Boolean is + begin + return Ada_Version >= Ada_2022 + and then Is_Homogeneous_Aggregate (N) + and then Is_Empty_List (Expressions (N)) + and then Is_Empty_List (Component_Associations (N)); + end Is_Null_Aggregate; + + ---------------------------------------- + -- Is_Null_Array_Aggregate_High_Bound -- + ---------------------------------------- + + function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean is + Original_N : constant Node_Id := Original_Node (N); + begin + return Ada_Version >= Ada_2022 + and then not Comes_From_Source (Original_N) + and then Nkind (Original_N) = N_Attribute_Reference + and then + Get_Attribute_Id (Attribute_Name (Original_N)) = Attribute_Pred + and then Nkind (Parent (N)) in N_Range | N_Op_Le + and then not Comes_From_Source (Parent (N)); + end Is_Null_Array_Aggregate_High_Bound; + -------------------------------- -- Make_String_Into_Aggregate -- -------------------------------- @@ -983,13 +1025,14 @@ package body Sem_Aggr is Array_Aggregate : declare Aggr_Resolved : Boolean; - Aggr_Typ : constant Entity_Id := Etype (Typ); -- This is the unconstrained array type, which is the type against -- which the aggregate is to be resolved. Typ itself is the array -- type of the context which may not be the same subtype as the -- subtype for the final aggregate. + Is_Null_Aggr : constant Boolean := Is_Null_Aggregate (N); + begin -- In the following we determine whether an OTHERS choice is -- allowed inside the array aggregate. The test checks the context @@ -1021,7 +1064,11 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- May be overridden later on - if Nkind (Parent (N)) = N_Assignment_Statement + if Is_Null_Aggr then + Set_Etype (N, Typ); + Aggr_Resolved := Resolve_Null_Array_Aggregate (N); + + elsif Nkind (Parent (N)) = N_Assignment_Statement or else Inside_Init_Proc or else (Is_Constrained (Typ) and then Nkind (Parent (N)) in @@ -1074,6 +1121,9 @@ package body Sem_Aggr is Aggr_Subtyp := Any_Composite; + elsif Is_Null_Aggr then + Aggr_Subtyp := Etype (N); + else Aggr_Subtyp := Array_Aggr_Subtype (N, Typ); end if; @@ -3139,8 +3189,12 @@ package body Sem_Aggr is end loop; end if; - if Present (Component_Associations (N)) then - if Present (Expressions (N)) then + if Present (Component_Associations (N)) + and then not Is_Empty_List (Component_Associations (N)) + then + if Present (Expressions (N)) + and then not Is_Empty_List (Expressions (N)) + then Error_Msg_N ("container aggregate cannot be " & "both positional and named", N); return; @@ -3957,6 +4011,77 @@ package body Sem_Aggr is Check_Function_Writable_Actuals (N); end Resolve_Extension_Aggregate; + ---------------------------------- + -- Resolve_Null_Array_Aggregate -- + ---------------------------------- + + function Resolve_Null_Array_Aggregate (N : Node_Id) return Boolean is + -- Never returns False, but declared as a function to match + -- other Resolve_Mumble functions. + + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + Check : Node_Id; + Decl : Node_Id; + Index : Node_Id; + Lo, Hi : Node_Id; + Constr : constant List_Id := New_List; + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); + + begin + -- Create a constrained subtype with null dimensions + + Index := First_Index (Typ); + while Present (Index) loop + Get_Index_Bounds (Index, L => Lo, H => Hi); + + -- The upper bound is the predecessor of the lower bound + + Hi := Make_Attribute_Reference + (Loc, + Prefix => New_Occurrence_Of (Etype (Index), Loc), + Attribute_Name => Name_Pred, + Expressions => New_List (New_Copy_Tree (Lo))); + + -- Check that high bound (i.e., low bound predecessor) exists. + -- Fail if low bound is low bound of base subtype (in all cases, + -- including modular). + + Check := + Make_If_Statement (Loc, + Condition => + Make_Op_Le (Loc, New_Copy_Tree (Lo), New_Copy_Tree (Hi)), + Then_Statements => + New_List (Make_Raise_Constraint_Error + (Loc, Reason => CE_Range_Check_Failed))); + + Insert_Action (N, Check); + + Append (Make_Range (Loc, Lo, Hi), Constr); + + Index := Next_Index (Index); + end loop; + + Decl := Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, Constr))); + + Insert_Action (N, Decl); + Set_Is_Internal (Subt); + Analyze (Decl); + Set_Etype (N, Subt); + Set_Compile_Time_Known_Aggregate (N); + Set_Aggregate_Bounds (N, New_Copy_Tree (First_Index (Etype (N)))); + + return True; + end Resolve_Null_Array_Aggregate; + ------------------------------ -- Resolve_Record_Aggregate -- ------------------------------ diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads --- a/gcc/ada/sem_aggr.ads +++ b/gcc/ada/sem_aggr.ads @@ -43,4 +43,7 @@ package Sem_Aggr is -- WARNING: There is a matching C declaration of this subprogram in fe.h + function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean; + -- Returns True for the high bound of a null array aggregate. + end Sem_Aggr; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -52,6 +52,7 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sdefault; with Sem; use Sem; +with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; @@ -8438,6 +8439,12 @@ package body Sem_Attr is or else (Is_Static_Expression (E2) and then Is_Scalar_Type (Etype (E1)))) and then Id /= Attribute_Descriptor_Size + + -- If the front-end conjures up Integer'Pred (Integer'First) + -- as the high bound of a null array aggregate, then we don't + -- want to reject that as an illegal static expression. + + and then not Is_Null_Array_Aggregate_High_Bound (N) then Static := True; Set_Is_Static_Expression (N, True); @@ -9923,6 +9930,25 @@ package body Sem_Attr is Check_Expressions; return; + + -- Rewrite the FE-constructed high bound of a null array + -- aggregate to raise CE. + + elsif Is_Signed_Integer_Type (P_Type) + and then Expr_Value (E1) = + Expr_Value (Type_Low_Bound (P_Base_Type)) + and then Is_Null_Array_Aggregate_High_Bound (N) + then + Apply_Compile_Time_Constraint_Error + (N, "Pred of `&''First`", + CE_Overflow_Check_Failed, + Ent => P_Base_Type, + Warn => True); + + Rewrite (N, Make_Raise_Constraint_Error (Sloc (N), + Reason => CE_Overflow_Check_Failed)); + Set_Etype (N, P_Base_Type); + return; end if; Fold_Uint (N, Expr_Value (E1) - 1, Static); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -43,6 +43,7 @@ with Opt; use Opt; with Par_SCO; use Par_SCO; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aggr; use Sem_Aggr; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; @@ -6054,6 +6055,16 @@ package body Sem_Eval is ------------------ procedure Out_Of_Range (N : Node_Id) is + + -- If the FE conjures up an expression that would normally be + -- an illegal static expression (e.g., an integer literal with + -- a value outside of its base subtype), we don't want to + -- flag it as illegal; we only want a warning in such cases. + + function Force_Warning return Boolean is + (if Comes_From_Source (Original_Node (N)) then False + elsif Nkind (Original_Node (N)) = N_Type_Conversion then True + else Is_Null_Array_Aggregate_High_Bound (N)); begin -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an @@ -6093,9 +6104,7 @@ package body Sem_Eval is -- Determine if the out-of-range violation constitutes a warning -- or an error based on context, according to RM 4.9 (34/3). - if Nkind (Original_Node (N)) = N_Type_Conversion - and then not Comes_From_Source (Original_Node (N)) - then + if Force_Warning then Apply_Compile_Time_Constraint_Error (N, "value not in range of}??", CE_Range_Check_Failed); else