From: Bob Duff Date: Mon, 6 Apr 2020 20:35:31 +0000 (-0400) Subject: [Ada] Declare expressions X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bcc0f556a7ed261d8270a925fd4823c7136783f0;p=gcc.git [Ada] Declare expressions 2020-06-16 Bob Duff gcc/ada/ * par-ch4.adb (P_Case_Expression): Move to be local. (P_Declare_Expression): New parsing routine. (P_Unparen_Cond_Expr_Etc): New name for P_Unparen_Cond_Case_Quant_Expression which was missing one case in its name (iterated component association), and we're adding a new case (declare expression), so lets use "Etc" instead of trying to pack all those things into the name. Add call to P_Declare_Expression, and check for missing parens. (P_Expression_If_OK, P_Expression_Or_Range_Attribute_If_OK): Add Tok_Declare. * par.adb (P_Basic_Declarative_Items): Add parameter Declare_Expression so we can tailor the error message about incorrect bodies. (P_Case_Expression): Move to body. * par-ch3.adb (P_Basic_Declarative_Items): Tailor the error message about incorrect bodies. * par-ch7.adb (P_Package): Pass Declare_Expression => False to P_Basic_Declarative_Items. * sem.ads (In_Declare_Expr): Counter used to determine whether we are analyzing a declare_expression. Needed to give errors about things that are not allowed in declare_expression, such as the 'Access attribute. * sem.adb (Do_Analyze): Save/restore In_Declare_Expr. * sem_ch4.adb (Analyze_Expression_With_Actions): Give this node its own scope. That seems better in general, but it is necessary for declare_expressions. For example, an identifier declared in a declare_expression should not clash with the same identifier in an outer scope. If this is a declare_expression, indicated by Comes_From_Source, then check legality rules, and incr/decr In_Declare_Expr. * sem_aggr.adb (Resolve_Aggregate): Allow an applicable index constraint for a declare_expression, so if its expression is an array aggregate, it can have "others => ...". * sem_attr.adb (Analyze_Access_Attribute): Disallow these attributes in declare_expressions. Add comment to make it clear that Unrestricted_Access is included. * sinfo.ads, sinfo.adb, atree.ads, atree.adb: Remove the now-incorrect comment in sinfo.ads that says N_Expression_With_Actions has no proper scope. Add 17-parameter versions of Nkind_In. Remove the 16-parameter versions of Nkind_In. --- diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 5c60a472b19..b342add9c99 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1940,11 +1940,12 @@ package body Atree is V13 : Node_Kind; V14 : Node_Kind; V15 : Node_Kind; - V16 : Node_Kind) return Boolean + V16 : Node_Kind; + V17 : Node_Kind) return Boolean is begin return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9, V10, - V11, V12, V13, V14, V15, V16); + V11, V12, V13, V14, V15, V16, V17); end Nkind_In; -------- diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index f9ebc38e554..68415d49ecb 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -772,7 +772,7 @@ package Atree is V10 : Node_Kind; V11 : Node_Kind) return Boolean; - -- 12..15-parameter versions are not yet needed + -- 12..16-parameter versions are not yet needed function Nkind_In (N : Node_Id; @@ -791,7 +791,8 @@ package Atree is V13 : Node_Kind; V14 : Node_Kind; V15 : Node_Kind; - V16 : Node_Kind) return Boolean; + V16 : Node_Kind; + V17 : Node_Kind) return Boolean; pragma Inline (Nkind_In); -- Inline all above functions diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 34d93632bdb..1fadf368c18 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -4702,7 +4702,9 @@ package body Ch3 is -- the scan pointer is repositioned past the next semicolon, and the scan -- for declarative items continues. - function P_Basic_Declarative_Items return List_Id is + function P_Basic_Declarative_Items + (Declare_Expression : Boolean) return List_Id + is Decl : Node_Id; Decls : List_Id; Kind : Node_Kind; @@ -4750,7 +4752,15 @@ package body Ch3 is Kind = N_Task_Body or else Kind = N_Protected_Body then - Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); + if Declare_Expression then + Error_Msg + ("proper body not allowed in declare_expression", + Sloc (Decl)); + else + Error_Msg + ("proper body not allowed in package spec", + Sloc (Decl)); + end if; -- Complete declaration of mangled subprogram body, for better -- recovery if analysis is attempted. diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index fe7b577572c..e3f3f06f8a8 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -72,23 +72,24 @@ package body Ch4 is -- Local Subprograms -- ----------------------- - function P_Aggregate_Or_Paren_Expr return Node_Id; - function P_Allocator return Node_Id; - function P_Case_Expression_Alternative return Node_Id; - function P_Iterated_Component_Association return Node_Id; - function P_Record_Or_Array_Component_Association return Node_Id; - function P_Factor return Node_Id; - function P_Primary return Node_Id; - function P_Relation return Node_Id; - function P_Term return Node_Id; + function P_Aggregate_Or_Paren_Expr return Node_Id; + function P_Allocator return Node_Id; + function P_Case_Expression_Alternative return Node_Id; + function P_Iterated_Component_Association return Node_Id; + function P_Record_Or_Array_Component_Association return Node_Id; + function P_Factor return Node_Id; + function P_Primary return Node_Id; + function P_Relation return Node_Id; + function P_Term return Node_Id; + function P_Declare_Expression return Node_Id; function P_Reduction_Attribute_Reference (S : Node_Id) return Node_Id; - function P_Binary_Adding_Operator return Node_Kind; - function P_Logical_Operator return Node_Kind; - function P_Multiplying_Operator return Node_Kind; - function P_Relational_Operator return Node_Kind; - function P_Unary_Adding_Operator return Node_Kind; + function P_Binary_Adding_Operator return Node_Kind; + function P_Logical_Operator return Node_Kind; + function P_Multiplying_Operator return Node_Kind; + function P_Relational_Operator return Node_Kind; + function P_Unary_Adding_Operator return Node_Kind; procedure Bad_Range_Attribute (Loc : Source_Ptr); -- Called to place complaint about bad range attribute at the given @@ -107,11 +108,18 @@ package body Ch4 is -- prefix. The current token is known to be an apostrophe and the -- following token is known to be RANGE. - function P_Unparen_Cond_Case_Quant_Expression return Node_Id; - -- This function is called with Token pointing to IF, CASE, or FOR, in a - -- context that allows a case, conditional, or quantified expression if - -- it is surrounded by parentheses. If not surrounded by parentheses, the - -- expression is still returned, but an error message is issued. + function P_Case_Expression return Node_Id; + -- Scans out a case expression. Called with Token pointing to the CASE + -- keyword, and returns pointing to the terminating right parent, + -- semicolon, or comma, but does not consume this terminating token. + + function P_Unparen_Cond_Expr_Etc return Node_Id; + -- This function is called with Token pointing to IF, CASE, FOR, or + -- DECLARE, in a context that allows a conditional (if or case) expression, + -- a quantified expression, an iterated component association, or a declare + -- expression, if it is surrounded by parentheses. If not surrounded by + -- parentheses, the expression is still returned, but an error message is + -- issued. ------------------------- -- Bad_Range_Attribute -- @@ -1944,8 +1952,12 @@ package body Ch4 is begin -- Case of conditional, case or quantified expression - if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then - return P_Unparen_Cond_Case_Quant_Expression; + if Token = Tok_Case + or else Token = Tok_If + or else Token = Tok_For + or else Token = Tok_Declare + then + return P_Unparen_Cond_Expr_Etc; -- Normal case, not case/conditional/quantified expression @@ -2053,8 +2065,12 @@ package body Ch4 is begin -- Case of conditional, case or quantified expression - if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then - return P_Unparen_Cond_Case_Quant_Expression; + if Token = Tok_Case + or else Token = Tok_If + or else Token = Tok_For + or else Token = Tok_Declare + then + return P_Unparen_Cond_Expr_Etc; -- Normal case, not one of the above expression types @@ -3442,7 +3458,7 @@ package body Ch4 is (Loc : Source_Ptr; Cond : Node_Id) return Node_Id is - Exprs : constant List_Id := New_List; + Exprs : constant List_Id := New_List; Expr : Node_Id; State : Saved_Scan_State; Eptr : Source_Ptr; @@ -3557,6 +3573,49 @@ package body Ch4 is return If_Expr; end P_If_Expression; + -------------------------- + -- P_Declare_Expression -- + -------------------------- + + -- DECLARE_EXPRESSION ::= + -- DECLARE {DECLARE_ITEM} + -- begin BODY_EXPRESSION + + -- DECLARE_ITEM ::= OBJECT_DECLARATION + -- | OBJECT_RENAMING_DECLARATION + + function P_Declare_Expression return Node_Id is + Loc : constant Source_Ptr := Token_Ptr; + begin + Scan; -- past IF + + declare + Actions : constant List_Id := P_Basic_Declarative_Items + (Declare_Expression => True); + -- Most declarative items allowed by P_Basic_Declarative_Items are + -- illegal; semantic analysis will deal with that. + begin + if Token = Tok_Begin then + Scan; + else + Error_Msg_SC -- CODEFIX + ("BEGIN expected!"); + end if; + + declare + Expression : constant Node_Id := P_Expression; + Result : constant Node_Id := + Make_Expression_With_Actions (Loc, Actions, Expression); + begin + if Ada_Version < Ada_2020 then + Error_Msg ("declare_expression is an Ada 2020 feature", Loc); + end if; + + return Result; + end; + end; + end P_Declare_Expression; + ----------------------- -- P_Membership_Test -- ----------------------- @@ -3594,11 +3653,11 @@ package body Ch4 is end if; end P_Membership_Test; - ------------------------------------------ - -- P_Unparen_Cond_Case_Quant_Expression -- - ------------------------------------------ + ----------------------------- + -- P_Unparen_Cond_Expr_Etc -- + ----------------------------- - function P_Unparen_Cond_Case_Quant_Expression return Node_Id is + function P_Unparen_Cond_Expr_Etc return Node_Id is Lparen : constant Boolean := Prev_Token = Tok_Left_Paren; Result : Node_Id; @@ -3647,6 +3706,15 @@ package body Ch4 is Result := P_Iterated_Component_Association; end if; + -- Declare expression + + elsif Token = Tok_Declare then + Result := P_Declare_Expression; + + if not (Lparen and then Token = Tok_Right_Paren) then + Error_Msg_N ("declare expression must be parenthesized!", Result); + end if; + -- No other possibility should exist (caller was supposed to check) else @@ -3656,6 +3724,6 @@ package body Ch4 is -- Return expression (possibly after having given message) return Result; - end P_Unparen_Cond_Case_Quant_Expression; + end P_Unparen_Cond_Expr_Etc; end Ch4; diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index e057daa52c5..9645250cd5b 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -265,7 +265,8 @@ package body Ch7 is Set_Defining_Unit_Name (Specification_Node, Name_Node); Set_Visible_Declarations - (Specification_Node, P_Basic_Declarative_Items); + (Specification_Node, + P_Basic_Declarative_Items (Declare_Expression => False)); if Token = Tok_Private then Error_Msg_Col := Scopes (Scope.Last).Ecol; @@ -282,7 +283,8 @@ package body Ch7 is Scan; -- past PRIVATE Set_Private_Declarations - (Specification_Node, P_Basic_Declarative_Items); + (Specification_Node, + P_Basic_Declarative_Items (Declare_Expression => False)); -- Deal gracefully with multiple PRIVATE parts @@ -290,8 +292,10 @@ package body Ch7 is Error_Msg_SC ("only one private part allowed per package"); Scan; -- past PRIVATE - Append_List (P_Basic_Declarative_Items, - Private_Declarations (Specification_Node)); + Append_List + (P_Basic_Declarative_Items + (Declare_Expression => False), + Private_Declarations (Specification_Node)); end loop; end if; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 380386a8534..78790808abd 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -679,7 +679,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- begin message if indeed the BEGIN is missing. function P_Array_Type_Definition return Node_Id; - function P_Basic_Declarative_Items return List_Id; function P_Constraint_Opt return Node_Id; function P_Declarative_Part return List_Id; function P_Discrete_Choice_List return List_Id; @@ -694,6 +693,14 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Subtype_Mark_Resync return Node_Id; function P_Unknown_Discriminant_Part_Opt return Boolean; + function P_Basic_Declarative_Items + (Declare_Expression : Boolean) return List_Id; + -- Used to parse the declarative items in a package visible or + -- private part (in which case Declare_Expression is False), and + -- the declare_items of a declare_expression (in which case + -- Declare_Expression is True). Declare_Expression is used to + -- affect the wording of error messages. + function P_Access_Definition (Null_Exclusion_Present : Boolean) return Node_Id; -- Ada 2005 (AI-231/AI-254): The caller parses the null-exclusion part @@ -787,11 +794,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is function P_Simple_Expression return Node_Id; function P_Simple_Expression_Or_Range_Attribute return Node_Id; - function P_Case_Expression return Node_Id; - -- Scans out a case expression. Called with Token pointing to the CASE - -- keyword, and returns pointing to the terminating right parent, - -- semicolon, or comma, but does not consume this terminating token. - function P_Expression_If_OK return Node_Id; -- Scans out an expression allowing an unparenthesized case expression, -- if expression, or quantified expression to appear without enclosing diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 44aac6346dc..b84df652aa5 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -1412,6 +1412,7 @@ package body Sem is S_GNAT_Mode : constant Boolean := GNAT_Mode; S_Global_Dis_Names : constant Boolean := Global_Discard_Names; S_In_Assertion_Expr : constant Nat := In_Assertion_Expr; + S_In_Declare_Expr : constant Nat := In_Declare_Expr; S_In_Default_Expr : constant Boolean := In_Default_Expr; S_In_Spec_Expr : constant Boolean := In_Spec_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; @@ -1523,6 +1524,7 @@ package body Sem is Full_Analysis := True; Inside_A_Generic := False; In_Assertion_Expr := 0; + In_Declare_Expr := 0; In_Default_Expr := False; In_Spec_Expression := False; Set_Comes_From_Source_Default (False); @@ -1607,6 +1609,7 @@ package body Sem is Global_Discard_Names := S_Global_Dis_Names; GNAT_Mode := S_GNAT_Mode; In_Assertion_Expr := S_In_Assertion_Expr; + In_Declare_Expr := S_In_Declare_Expr; In_Default_Expr := S_In_Default_Expr; In_Spec_Expression := S_In_Spec_Expr; Inside_A_Generic := S_Inside_A_Generic; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index e8917741bee..d7f8cdb9cb7 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -245,13 +245,20 @@ package Sem is In_Assertion_Expr : Nat := 0; -- This is set non-zero if we are within the expression of an assertion - -- pragma or aspect. It is a counter which is incremented at the start of - -- expanding such an expression, and decremented on completion of expanding - -- that expression. Probably a boolean would be good enough, since we think - -- that such expressions cannot nest, but that might not be true in the - -- future (e.g. if let expressions are added to Ada) so we prepare for that - -- future possibility by making it a counter. As with In_Spec_Expression, - -- it must be recursively saved and restored for a Semantics call. + -- pragma or aspect. It is incremented at the start of expanding such an + -- expression, and decremented on completion of expanding that + -- expression. This needs to be a counter, rather than a Boolean, because + -- assertions can contain declare_expressions, which can contain + -- assertions. As with In_Spec_Expression, it must be recursively saved and + -- restored for a Semantics call. + + In_Declare_Expr : Nat := 0; + -- This is set non-zero if we are within a declare_expression. It is + -- incremented at the start of expanding such an expression, and + -- decremented on completion of expanding that expression. This needs to be + -- a counter, rather than a Boolean, because declare_expressions can + -- nest. As with In_Spec_Expression, it must be recursively saved and + -- restored for a Semantics call. In_Compile_Time_Warning_Or_Error : Boolean := False; -- Switch to indicate that we are validating a pragma Compile_Time_Warning diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 3152305194c..8608d98ca49 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -976,7 +976,8 @@ package body Sem_Aggr is N_Extension_Aggregate, N_Component_Association, N_Case_Expression_Alternative, - N_If_Expression)) + N_If_Expression, + N_Expression_With_Actions)) then Aggr_Resolved := Resolve_Array_Aggregate diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 6f9a7451e91..23fc0214007 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -801,6 +801,14 @@ package body Sem_Attr is -- Start of processing for Analyze_Access_Attribute begin + -- Access and Unchecked_Access are illegal in declare_expressions, + -- according to the RM. We also make the GNAT-specific + -- Unrestricted_Access attribute illegal. + + if In_Declare_Expr > 0 then + Error_Attr ("% attribute cannot occur in a declare_expression", N); + end if; + Check_E0; if Nkind (P) = N_Character_Literal then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index fe8aed59768..54531560501 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2216,18 +2216,94 @@ package body Sem_Ch4 is -- Analyze_Expression_With_Actions -- ------------------------------------- + -- Start of processing for Analyze_Quantified_Expression + procedure Analyze_Expression_With_Actions (N : Node_Id) is + + procedure Check_Action_OK (A : Node_Id); + -- Check that the action is something that is allows as a declare_item + -- of a declare_expression, except the checks are suppressed for + -- generated code. + + procedure Check_Action_OK (A : Node_Id) is + begin + if not Comes_From_Source (N) or else not Comes_From_Source (A) then + return; -- Allow anything in generated code + end if; + + case Nkind (A) is + when N_Object_Declaration => + if Nkind (Object_Definition (A)) = N_Access_Definition then + Error_Msg_N + ("anonymous access type not allowed in declare_expression", + Object_Definition (A)); + end if; + + if Aliased_Present (A) then + Error_Msg_N ("aliased not allowed in declare_expression", A); + end if; + + if Constant_Present (A) + and then not Is_Limited_Type (Etype (Defining_Identifier (A))) + then + return; -- nonlimited constants are OK + end if; + + when N_Object_Renaming_Declaration => + if Present (Access_Definition (A)) then + Error_Msg_N + ("anonymous access type not allowed in declare_expression", + Access_Definition (A)); + end if; + + if not Is_Limited_Type (Etype (Defining_Identifier (A))) then + return; -- ???For now; the RM rule is a bit more complicated + end if; + + when others => + null; -- Nothing else allowed, not even pragmas + end case; + + Error_Msg_N ("object renaming or constant declaration expected", A); + end Check_Action_OK; + A : Node_Id; + EWA_Scop : Entity_Id; + + -- Start of processing for Analyze_Expression_With_Actions begin + -- Create a scope, which is needed to provide proper visibility of the + -- declare_items. + + EWA_Scop := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); + Set_Etype (EWA_Scop, Standard_Void_Type); + Set_Scope (EWA_Scop, Current_Scope); + Set_Parent (EWA_Scop, N); + Push_Scope (EWA_Scop); + + -- If this Expression_With_Actions node comes from source, then it + -- represents a declare_expression; increment the counter to take note + -- of that. + + if Comes_From_Source (N) then + In_Declare_Expr := In_Declare_Expr + 1; + end if; + A := First (Actions (N)); while Present (A) loop Analyze (A); + Check_Action_OK (A); Next (A); end loop; Analyze_Expression (Expression (N)); Set_Etype (N, Etype (Expression (N))); + End_Scope; + + if Comes_From_Source (N) then + In_Declare_Expr := In_Declare_Expr - 1; + end if; end Analyze_Expression_With_Actions; --------------------------- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 642e859a5e8..7368db64ddd 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -7288,7 +7288,8 @@ package body Sinfo is V13 : Node_Kind; V14 : Node_Kind; V15 : Node_Kind; - V16 : Node_Kind) return Boolean + V16 : Node_Kind; + V17 : Node_Kind) return Boolean is begin return T = V1 or else @@ -7306,7 +7307,8 @@ package body Sinfo is T = V13 or else T = V14 or else T = V15 or else - T = V16; + T = V16 or else + T = V17; end Nkind_In; -------------------------- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 7bec540ccee..41847d8eb24 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -7994,9 +7994,18 @@ package Sinfo is -- executing all the actions. -- If the actions contain declarations, then these declarations may - -- be referenced within the expression. However note that there is - -- no proper scope associated with the expression-with-action, so the - -- back-end will elaborate them in the context of the enclosing scope. + -- be referenced within the expression. + + -- (AI12-0236-1): In Ada 2020, for a declare_expression, the parser + -- generates an N_Expression_With_Actions. Declare_expressions have + -- various restrictions, which we do not enforce on + -- N_Expression_With_Actions nodes that are generated by the + -- expander. The two cases can be distinguished by looking at + -- Comes_From_Source. + + -- ???Perhaps we should change the name of this node to + -- N_Declare_Expression, and perhaps we should change the Sprint syntax + -- to match the RM syntax for declare_expression. -- Sprint syntax: do -- action; @@ -11466,7 +11475,7 @@ package Sinfo is V10 : Node_Kind; V11 : Node_Kind) return Boolean; - -- 12..15-parameter versions are not yet needed + -- 12..16-parameter versions are not yet needed function Nkind_In (T : Node_Kind; @@ -11485,7 +11494,8 @@ package Sinfo is V13 : Node_Kind; V14 : Node_Kind; V15 : Node_Kind; - V16 : Node_Kind) return Boolean; + V16 : Node_Kind; + V17 : Node_Kind) return Boolean; pragma Inline (Nkind_In); -- Inline all above functions