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;
--------
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;
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
-- 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;
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.
-- 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
-- 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 --
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
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
(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;
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 --
-----------------------
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;
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
-- Return expression (possibly after having given message)
return Result;
- end P_Unparen_Cond_Case_Quant_Expression;
+ end P_Unparen_Cond_Expr_Etc;
end Ch4;
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;
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
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;
-- 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;
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
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
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;
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);
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;
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
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
-- 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
-- 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;
---------------------------
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
T = V13 or else
T = V14 or else
T = V15 or else
- T = V16;
+ T = V16 or else
+ T = V17;
end Nkind_In;
--------------------------
-- 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;
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;
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
projects / gcc.git / commitdiff