aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8/gcc/ada/par-ch4.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8/gcc/ada/par-ch4.adb')
-rw-r--r--gcc-4.8/gcc/ada/par-ch4.adb3205
1 files changed, 0 insertions, 3205 deletions
diff --git a/gcc-4.8/gcc/ada/par-ch4.adb b/gcc-4.8/gcc/ada/par-ch4.adb
deleted file mode 100644
index 185a07d97..000000000
--- a/gcc-4.8/gcc/ada/par-ch4.adb
+++ /dev/null
@@ -1,3205 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P A R . C H 4 --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Style_Checks (All_Checks);
--- Turn off subprogram body ordering check. Subprograms are in order
--- by RM section rather than alphabetical
-
-with Stringt; use Stringt;
-
-separate (Par)
-package body Ch4 is
-
- -- Attributes that cannot have arguments
-
- Is_Parameterless_Attribute : constant Attribute_Class_Array :=
- (Attribute_Base => True,
- Attribute_Body_Version => True,
- Attribute_Class => True,
- Attribute_External_Tag => True,
- Attribute_Img => True,
- Attribute_Stub_Type => True,
- Attribute_Version => True,
- Attribute_Type_Key => True,
- others => False);
- -- This map contains True for parameterless attributes that return a
- -- string or a type. For those attributes, a left parenthesis after
- -- the attribute should not be analyzed as the beginning of a parameters
- -- list because it may denote a slice operation (X'Img (1 .. 2)) or
- -- a type conversion (X'Class (Y)).
-
- -- Note that this map designates the minimum set of attributes where a
- -- construct in parentheses that is not an argument can appear right
- -- after the attribute. For attributes like 'Size, we do not put them
- -- in the map. If someone writes X'Size (3), that's illegal in any case,
- -- but we get a better error message by parsing the (3) as an illegal
- -- argument to the attribute, rather than some meaningless junk that
- -- follows the attribute.
-
- -----------------------
- -- 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_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_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
- -- source location. Terminates by raising Error_Resync.
-
- procedure Check_Bad_Exp;
- -- Called after scanning a**b, posts error if ** detected
-
- procedure P_Membership_Test (N : Node_Id);
- -- N is the node for a N_In or N_Not_In node whose right operand has not
- -- yet been processed. It is called just after scanning out the IN keyword.
- -- On return, either Right_Opnd or Alternatives is set, as appropriate.
-
- function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
- -- Scan a range attribute reference. The caller has scanned out the
- -- 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.
-
- -------------------------
- -- Bad_Range_Attribute --
- -------------------------
-
- procedure Bad_Range_Attribute (Loc : Source_Ptr) is
- begin
- Error_Msg ("range attribute cannot be used in expression!", Loc);
- Resync_Expression;
- end Bad_Range_Attribute;
-
- -------------------
- -- Check_Bad_Exp --
- -------------------
-
- procedure Check_Bad_Exp is
- begin
- if Token = Tok_Double_Asterisk then
- Error_Msg_SC ("parenthesization required for '*'*");
- Scan; -- past **
- Discard_Junk_Node (P_Primary);
- Check_Bad_Exp;
- end if;
- end Check_Bad_Exp;
-
- --------------------------
- -- 4.1 Name (also 6.4) --
- --------------------------
-
- -- NAME ::=
- -- DIRECT_NAME | EXPLICIT_DEREFERENCE
- -- | INDEXED_COMPONENT | SLICE
- -- | SELECTED_COMPONENT | ATTRIBUTE
- -- | TYPE_CONVERSION | FUNCTION_CALL
- -- | CHARACTER_LITERAL
-
- -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
-
- -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE
-
- -- EXPLICIT_DEREFERENCE ::= NAME . all
-
- -- IMPLICIT_DEREFERENCE ::= NAME
-
- -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
-
- -- SLICE ::= PREFIX (DISCRETE_RANGE)
-
- -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
-
- -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
-
- -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
-
- -- ATTRIBUTE_DESIGNATOR ::=
- -- IDENTIFIER [(static_EXPRESSION)]
- -- | access | delta | digits
-
- -- FUNCTION_CALL ::=
- -- function_NAME
- -- | function_PREFIX ACTUAL_PARAMETER_PART
-
- -- ACTUAL_PARAMETER_PART ::=
- -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
-
- -- PARAMETER_ASSOCIATION ::=
- -- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
-
- -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
-
- -- Note: syntactically a procedure call looks just like a function call,
- -- so this routine is in practice used to scan out procedure calls as well.
-
- -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name
-
- -- Error recovery: can raise Error_Resync
-
- -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
- -- followed by either a left paren (qualified expression case), or by
- -- range (range attribute case). All other uses of apostrophe (i.e. all
- -- other attributes) are handled in this routine.
-
- -- Error recovery: can raise Error_Resync
-
- function P_Name return Node_Id is
- Scan_State : Saved_Scan_State;
- Name_Node : Node_Id;
- Prefix_Node : Node_Id;
- Ident_Node : Node_Id;
- Expr_Node : Node_Id;
- Range_Node : Node_Id;
- Arg_Node : Node_Id;
-
- Arg_List : List_Id := No_List; -- kill junk warning
- Attr_Name : Name_Id := No_Name; -- kill junk warning
-
- begin
- -- Case of not a name
-
- if Token not in Token_Class_Name then
-
- -- If it looks like start of expression, complain and scan expression
-
- if Token in Token_Class_Literal
- or else Token = Tok_Left_Paren
- then
- Error_Msg_SC ("name expected");
- return P_Expression;
-
- -- Otherwise some other junk, not much we can do
-
- else
- Error_Msg_AP ("name expected");
- raise Error_Resync;
- end if;
- end if;
-
- -- Loop through designators in qualified name
-
- Name_Node := Token_Node;
-
- loop
- Scan; -- past designator
- exit when Token /= Tok_Dot;
- Save_Scan_State (Scan_State); -- at dot
- Scan; -- past dot
-
- -- If we do not have another designator after the dot, then join
- -- the normal circuit to handle a dot extension (may be .all or
- -- character literal case). Otherwise loop back to scan the next
- -- designator.
-
- if Token not in Token_Class_Desig then
- goto Scan_Name_Extension_Dot;
- else
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Selector_Name (Name_Node, Token_Node);
- end if;
- end loop;
-
- -- We have now scanned out a qualified designator. If the last token is
- -- an operator symbol, then we certainly do not have the Snam case, so
- -- we can just use the normal name extension check circuit
-
- if Prev_Token = Tok_Operator_Symbol then
- goto Scan_Name_Extension;
- end if;
-
- -- We have scanned out a qualified simple name, check for name extension
- -- Note that we know there is no dot here at this stage, so the only
- -- possible cases of name extension are apostrophe and left paren.
-
- if Token = Tok_Apostrophe then
- Save_Scan_State (Scan_State); -- at apostrophe
- Scan; -- past apostrophe
-
- -- Qualified expression in Ada 2012 mode (treated as a name)
-
- if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
- goto Scan_Name_Extension_Apostrophe;
-
- -- If left paren not in Ada 2012, then it is not part of the name,
- -- since qualified expressions are not names in prior versions of
- -- Ada, so return with Token backed up to point to the apostrophe.
- -- The treatment for the range attribute is similar (we do not
- -- consider x'range to be a name in this grammar).
-
- elsif Token = Tok_Left_Paren or else Token = Tok_Range then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Expr_Form := EF_Simple_Name;
- return Name_Node;
-
- -- Otherwise we have the case of a name extended by an attribute
-
- else
- goto Scan_Name_Extension_Apostrophe;
- end if;
-
- -- Check case of qualified simple name extended by a left parenthesis
-
- elsif Token = Tok_Left_Paren then
- Scan; -- past left paren
- goto Scan_Name_Extension_Left_Paren;
-
- -- Otherwise the qualified simple name is not extended, so return
-
- else
- Expr_Form := EF_Simple_Name;
- return Name_Node;
- end if;
-
- -- Loop scanning past name extensions. A label is used for control
- -- transfer for this loop for ease of interfacing with the finite state
- -- machine in the parenthesis scanning circuit, and also to allow for
- -- passing in control to the appropriate point from the above code.
-
- <<Scan_Name_Extension>>
-
- -- Character literal used as name cannot be extended. Also this
- -- cannot be a call, since the name for a call must be a designator.
- -- Return in these cases, or if there is no name extension
-
- if Token not in Token_Class_Namext
- or else Prev_Token = Tok_Char_Literal
- then
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
-
- -- Merge here when we know there is a name extension
-
- <<Scan_Name_Extension_OK>>
-
- if Token = Tok_Left_Paren then
- Scan; -- past left paren
- goto Scan_Name_Extension_Left_Paren;
-
- elsif Token = Tok_Apostrophe then
- Save_Scan_State (Scan_State); -- at apostrophe
- Scan; -- past apostrophe
- goto Scan_Name_Extension_Apostrophe;
-
- else -- Token = Tok_Dot
- Save_Scan_State (Scan_State); -- at dot
- Scan; -- past dot
- goto Scan_Name_Extension_Dot;
- end if;
-
- -- Case of name extended by dot (selection), dot is already skipped
- -- and the scan state at the point of the dot is saved in Scan_State.
-
- <<Scan_Name_Extension_Dot>>
-
- -- Explicit dereference case
-
- if Token = Tok_All then
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Scan; -- past ALL
- goto Scan_Name_Extension;
-
- -- Selected component case
-
- elsif Token in Token_Class_Name then
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Selector_Name (Name_Node, Token_Node);
- Scan; -- past selector
- goto Scan_Name_Extension;
-
- -- Reserved identifier as selector
-
- elsif Is_Reserved_Identifier then
- Scan_Reserved_Identifier (Force_Msg => False);
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Selector_Name (Name_Node, Token_Node);
- Scan; -- past identifier used as selector
- goto Scan_Name_Extension;
-
- -- If dot is at end of line and followed by nothing legal,
- -- then assume end of name and quit (dot will be taken as
- -- an erroneous form of some other punctuation by our caller).
-
- elsif Token_Is_At_Start_Of_Line then
- Restore_Scan_State (Scan_State);
- return Name_Node;
-
- -- Here if nothing legal after the dot
-
- else
- Error_Msg_AP ("selector expected");
- raise Error_Resync;
- end if;
-
- -- Here for an apostrophe as name extension. The scan position at the
- -- apostrophe has already been saved, and the apostrophe scanned out.
-
- <<Scan_Name_Extension_Apostrophe>>
-
- Scan_Apostrophe : declare
- function Apostrophe_Should_Be_Semicolon return Boolean;
- -- Checks for case where apostrophe should probably be
- -- a semicolon, and if so, gives appropriate message,
- -- resets the scan pointer to the apostrophe, changes
- -- the current token to Tok_Semicolon, and returns True.
- -- Otherwise returns False.
-
- ------------------------------------
- -- Apostrophe_Should_Be_Semicolon --
- ------------------------------------
-
- function Apostrophe_Should_Be_Semicolon return Boolean is
- begin
- if Token_Is_At_Start_Of_Line then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Error_Msg_SC ("|""''"" should be "";""");
- Token := Tok_Semicolon;
- return True;
- else
- return False;
- end if;
- end Apostrophe_Should_Be_Semicolon;
-
- -- Start of processing for Scan_Apostrophe
-
- begin
- -- Check for qualified expression case in Ada 2012 mode
-
- if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
- Name_Node := P_Qualified_Expression (Name_Node);
- goto Scan_Name_Extension;
-
- -- If range attribute after apostrophe, then return with Token
- -- pointing to the apostrophe. Note that in this case the prefix
- -- need not be a simple name (cases like A.all'range). Similarly
- -- if there is a left paren after the apostrophe, then we also
- -- return with Token pointing to the apostrophe (this is the
- -- aggregate case, or some error case).
-
- elsif Token = Tok_Range or else Token = Tok_Left_Paren then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Expr_Form := EF_Name;
- return Name_Node;
-
- -- Here for cases where attribute designator is an identifier
-
- elsif Token = Tok_Identifier then
- Attr_Name := Token_Name;
-
- if not Is_Attribute_Name (Attr_Name) then
- if Apostrophe_Should_Be_Semicolon then
- Expr_Form := EF_Name;
- return Name_Node;
-
- -- Here for a bad attribute name
-
- else
- Signal_Bad_Attribute;
- Scan; -- past bad identifier
-
- if Token = Tok_Left_Paren then
- Scan; -- past left paren
-
- loop
- Discard_Junk_Node (P_Expression_If_OK);
- exit when not Comma_Present;
- end loop;
-
- T_Right_Paren;
- end if;
-
- return Error;
- end if;
- end if;
-
- if Style_Check then
- Style.Check_Attribute_Name (False);
- end if;
-
- -- Here for case of attribute designator is not an identifier
-
- else
- if Token = Tok_Delta then
- Attr_Name := Name_Delta;
-
- elsif Token = Tok_Digits then
- Attr_Name := Name_Digits;
-
- elsif Token = Tok_Access then
- Attr_Name := Name_Access;
-
- elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
- Attr_Name := Name_Mod;
-
- elsif Apostrophe_Should_Be_Semicolon then
- Expr_Form := EF_Name;
- return Name_Node;
-
- else
- Error_Msg_AP ("attribute designator expected");
- raise Error_Resync;
- end if;
-
- if Style_Check then
- Style.Check_Attribute_Name (True);
- end if;
- end if;
-
- -- We come here with an OK attribute scanned, and corresponding
- -- Attribute identifier node stored in Ident_Node.
-
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
- Scan; -- past attribute designator
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Attribute_Name (Name_Node, Attr_Name);
-
- -- Scan attribute arguments/designator. We skip this if we know
- -- that the attribute cannot have an argument.
-
- if Token = Tok_Left_Paren
- and then not
- Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
- then
- Set_Expressions (Name_Node, New_List);
-
- -- Attribute Update contains an array or record association
- -- list which provides new values for various components or
- -- elements. The list is parsed as an aggregate.
-
- if Attr_Name = Name_Update then
- Append (P_Aggregate, Expressions (Name_Node));
-
- else
- Scan; -- past left paren
-
- loop
- declare
- Expr : constant Node_Id := P_Expression_If_OK;
-
- begin
- if Token = Tok_Arrow then
- Error_Msg_SC
- ("named parameters not permitted for attributes");
- Scan; -- past junk arrow
-
- else
- Append (Expr, Expressions (Name_Node));
- exit when not Comma_Present;
- end if;
- end;
- end loop;
-
- T_Right_Paren;
- end if;
- end if;
-
- goto Scan_Name_Extension;
- end Scan_Apostrophe;
-
- -- Here for left parenthesis extending name (left paren skipped)
-
- <<Scan_Name_Extension_Left_Paren>>
-
- -- We now have to scan through a list of items, terminated by a
- -- right parenthesis. The scan is handled by a finite state
- -- machine. The possibilities are:
-
- -- (discrete_range)
-
- -- This is a slice. This case is handled in LP_State_Init
-
- -- (expression, expression, ..)
-
- -- This is interpreted as an indexed component, i.e. as a
- -- case of a name which can be extended in the normal manner.
- -- This case is handled by LP_State_Name or LP_State_Expr.
-
- -- Note: if and case expressions (without an extra level of
- -- parentheses) are permitted in this context).
-
- -- (..., identifier => expression , ...)
-
- -- If there is at least one occurrence of identifier => (but
- -- none of the other cases apply), then we have a call.
-
- -- Test for Id => case
-
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Scan; -- past Id
-
- -- Test for => (allow := as an error substitute)
-
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Restore_Scan_State (Scan_State); -- to Id
- Arg_List := New_List;
- goto LP_State_Call;
-
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
- end if;
-
- -- Here we have an expression after all
-
- Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
-
- -- Check cases of discrete range for a slice
-
- -- First possibility: Range_Attribute_Reference
-
- if Expr_Form = EF_Range_Attr then
- Range_Node := Expr_Node;
-
- -- Second possibility: Simple_expression .. Simple_expression
-
- elsif Token = Tok_Dot_Dot then
- Check_Simple_Expression (Expr_Node);
- Range_Node := New_Node (N_Range, Token_Ptr);
- Set_Low_Bound (Range_Node, Expr_Node);
- Scan; -- past ..
- Expr_Node := P_Expression;
- Check_Simple_Expression (Expr_Node);
- Set_High_Bound (Range_Node, Expr_Node);
-
- -- Third possibility: Type_name range Range
-
- elsif Token = Tok_Range then
- if Expr_Form /= EF_Simple_Name then
- Error_Msg_SC ("subtype mark must precede RANGE");
- raise Error_Resync;
- end if;
-
- Range_Node := P_Subtype_Indication (Expr_Node);
-
- -- Otherwise we just have an expression. It is true that we might
- -- have a subtype mark without a range constraint but this case
- -- is syntactically indistinguishable from the expression case.
-
- else
- Arg_List := New_List;
- goto LP_State_Expr;
- end if;
-
- -- Fall through here with unmistakable Discrete range scanned,
- -- which means that we definitely have the case of a slice. The
- -- Discrete range is in Range_Node.
-
- if Token = Tok_Comma then
- Error_Msg_SC ("slice cannot have more than one dimension");
- raise Error_Resync;
-
- elsif Token /= Tok_Right_Paren then
- if Token = Tok_Arrow then
-
- -- This may be an aggregate that is missing a qualification
-
- Error_Msg_SC
- ("context of aggregate must be a qualified expression");
- raise Error_Resync;
-
- else
- T_Right_Paren;
- raise Error_Resync;
- end if;
-
- else
- Scan; -- past right paren
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Discrete_Range (Name_Node, Range_Node);
-
- -- An operator node is legal as a prefix to other names,
- -- but not for a slice.
-
- if Nkind (Prefix_Node) = N_Operator_Symbol then
- Error_Msg_N ("illegal prefix for slice", Prefix_Node);
- end if;
-
- -- If we have a name extension, go scan it
-
- if Token in Token_Class_Namext then
- goto Scan_Name_Extension_OK;
-
- -- Otherwise return (a slice is a name, but is not a call)
-
- else
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
- end if;
-
- -- In LP_State_Expr, we have scanned one or more expressions, and
- -- so we have a call or an indexed component which is a name. On
- -- entry we have the expression just scanned in Expr_Node and
- -- Arg_List contains the list of expressions encountered so far
-
- <<LP_State_Expr>>
- Append (Expr_Node, Arg_List);
-
- if Token = Tok_Arrow then
- Error_Msg
- ("expect identifier in parameter association",
- Sloc (Expr_Node));
- Scan; -- past arrow
-
- elsif not Comma_Present then
- T_Right_Paren;
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
- Set_Prefix (Name_Node, Prefix_Node);
- Set_Expressions (Name_Node, Arg_List);
- goto Scan_Name_Extension;
- end if;
-
- -- Comma present (and scanned out), test for identifier => case
- -- Test for identifier => case
-
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Scan; -- past Id
-
- -- Test for => (allow := as error substitute)
-
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Restore_Scan_State (Scan_State); -- to Id
- goto LP_State_Call;
-
- -- Otherwise it's just an expression after all, so backup
-
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
- end if;
-
- -- Here we have an expression after all, so stay in this state
-
- Expr_Node := P_Expression_If_OK;
- goto LP_State_Expr;
-
- -- LP_State_Call corresponds to the situation in which at least
- -- one instance of Id => Expression has been encountered, so we
- -- know that we do not have a name, but rather a call. We enter
- -- it with the scan pointer pointing to the next argument to scan,
- -- and Arg_List containing the list of arguments scanned so far.
-
- <<LP_State_Call>>
-
- -- Test for case of Id => Expression (named parameter)
-
- if Token = Tok_Identifier then
- Save_Scan_State (Scan_State); -- at Id
- Ident_Node := Token_Node;
- Scan; -- past Id
-
- -- Deal with => (allow := as erroneous substitute)
-
- if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
- Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
- Set_Selector_Name (Arg_Node, Ident_Node);
- T_Arrow;
- Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
- Append (Arg_Node, Arg_List);
-
- -- If a comma follows, go back and scan next entry
-
- if Comma_Present then
- goto LP_State_Call;
-
- -- Otherwise we have the end of a call
-
- else
- Prefix_Node := Name_Node;
- Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
- Set_Name (Name_Node, Prefix_Node);
- Set_Parameter_Associations (Name_Node, Arg_List);
- T_Right_Paren;
-
- if Token in Token_Class_Namext then
- goto Scan_Name_Extension_OK;
-
- -- This is a case of a call which cannot be a name
-
- else
- Expr_Form := EF_Name;
- return Name_Node;
- end if;
- end if;
-
- -- Not named parameter: Id started an expression after all
-
- else
- Restore_Scan_State (Scan_State); -- to Id
- end if;
- end if;
-
- -- Here if entry did not start with Id => which means that it
- -- is a positional parameter, which is not allowed, since we
- -- have seen at least one named parameter already.
-
- Error_Msg_SC
- ("positional parameter association " &
- "not allowed after named one");
-
- Expr_Node := P_Expression_If_OK;
-
- -- Leaving the '>' in an association is not unusual, so suggest
- -- a possible fix.
-
- if Nkind (Expr_Node) = N_Op_Eq then
- Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
- end if;
-
- -- We go back to scanning out expressions, so that we do not get
- -- multiple error messages when several positional parameters
- -- follow a named parameter.
-
- goto LP_State_Expr;
-
- -- End of treatment for name extensions starting with left paren
-
- -- End of loop through name extensions
-
- end P_Name;
-
- -- This function parses a restricted form of Names which are either
- -- designators, or designators preceded by a sequence of prefixes
- -- that are direct names.
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Function_Name return Node_Id is
- Designator_Node : Node_Id;
- Prefix_Node : Node_Id;
- Selector_Node : Node_Id;
- Dot_Sloc : Source_Ptr := No_Location;
-
- begin
- -- Prefix_Node is set to the gathered prefix so far, Empty means that
- -- no prefix has been scanned. This allows us to build up the result
- -- in the required right recursive manner.
-
- Prefix_Node := Empty;
-
- -- Loop through prefixes
-
- loop
- Designator_Node := Token_Node;
-
- if Token not in Token_Class_Desig then
- return P_Identifier; -- let P_Identifier issue the error message
-
- else -- Token in Token_Class_Desig
- Scan; -- past designator
- exit when Token /= Tok_Dot;
- end if;
-
- -- Here at a dot, with token just before it in Designator_Node
-
- if No (Prefix_Node) then
- Prefix_Node := Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- Prefix_Node := Selector_Node;
- end if;
-
- Dot_Sloc := Token_Ptr;
- Scan; -- past dot
- end loop;
-
- -- Fall out of the loop having just scanned a designator
-
- if No (Prefix_Node) then
- return Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- return Selector_Node;
- end if;
-
- exception
- when Error_Resync =>
- return Error;
- end P_Function_Name;
-
- -- This function parses a restricted form of Names which are either
- -- identifiers, or identifiers preceded by a sequence of prefixes
- -- that are direct names.
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Qualified_Simple_Name return Node_Id is
- Designator_Node : Node_Id;
- Prefix_Node : Node_Id;
- Selector_Node : Node_Id;
- Dot_Sloc : Source_Ptr := No_Location;
-
- begin
- -- Prefix node is set to the gathered prefix so far, Empty means that
- -- no prefix has been scanned. This allows us to build up the result
- -- in the required right recursive manner.
-
- Prefix_Node := Empty;
-
- -- Loop through prefixes
-
- loop
- Designator_Node := Token_Node;
-
- if Token = Tok_Identifier then
- Scan; -- past identifier
- exit when Token /= Tok_Dot;
-
- elsif Token not in Token_Class_Desig then
- return P_Identifier; -- let P_Identifier issue the error message
-
- else
- Scan; -- past designator
-
- if Token /= Tok_Dot then
- Error_Msg_SP ("identifier expected");
- return Error;
- end if;
- end if;
-
- -- Here at a dot, with token just before it in Designator_Node
-
- if No (Prefix_Node) then
- Prefix_Node := Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- Prefix_Node := Selector_Node;
- end if;
-
- Dot_Sloc := Token_Ptr;
- Scan; -- past dot
- end loop;
-
- -- Fall out of the loop having just scanned an identifier
-
- if No (Prefix_Node) then
- return Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- return Selector_Node;
- end if;
-
- exception
- when Error_Resync =>
- return Error;
- end P_Qualified_Simple_Name;
-
- -- This procedure differs from P_Qualified_Simple_Name only in that it
- -- raises Error_Resync if any error is encountered. It only returns after
- -- scanning a valid qualified simple name.
-
- -- Error recovery: can raise Error_Resync
-
- function P_Qualified_Simple_Name_Resync return Node_Id is
- Designator_Node : Node_Id;
- Prefix_Node : Node_Id;
- Selector_Node : Node_Id;
- Dot_Sloc : Source_Ptr := No_Location;
-
- begin
- Prefix_Node := Empty;
-
- -- Loop through prefixes
-
- loop
- Designator_Node := Token_Node;
-
- if Token = Tok_Identifier then
- Scan; -- past identifier
- exit when Token /= Tok_Dot;
-
- elsif Token not in Token_Class_Desig then
- Discard_Junk_Node (P_Identifier); -- to issue the error message
- raise Error_Resync;
-
- else
- Scan; -- past designator
-
- if Token /= Tok_Dot then
- Error_Msg_SP ("identifier expected");
- raise Error_Resync;
- end if;
- end if;
-
- -- Here at a dot, with token just before it in Designator_Node
-
- if No (Prefix_Node) then
- Prefix_Node := Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- Prefix_Node := Selector_Node;
- end if;
-
- Dot_Sloc := Token_Ptr;
- Scan; -- past period
- end loop;
-
- -- Fall out of the loop having just scanned an identifier
-
- if No (Prefix_Node) then
- return Designator_Node;
- else
- Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
- Set_Prefix (Selector_Node, Prefix_Node);
- Set_Selector_Name (Selector_Node, Designator_Node);
- return Selector_Node;
- end if;
- end P_Qualified_Simple_Name_Resync;
-
- ----------------------
- -- 4.1 Direct_Name --
- ----------------------
-
- -- Parsed by P_Name and other functions in section 4.1
-
- -----------------
- -- 4.1 Prefix --
- -----------------
-
- -- Parsed by P_Name (4.1)
-
- -------------------------------
- -- 4.1 Explicit Dereference --
- -------------------------------
-
- -- Parsed by P_Name (4.1)
-
- -------------------------------
- -- 4.1 Implicit_Dereference --
- -------------------------------
-
- -- Parsed by P_Name (4.1)
-
- ----------------------------
- -- 4.1 Indexed Component --
- ----------------------------
-
- -- Parsed by P_Name (4.1)
-
- ----------------
- -- 4.1 Slice --
- ----------------
-
- -- Parsed by P_Name (4.1)
-
- -----------------------------
- -- 4.1 Selected_Component --
- -----------------------------
-
- -- Parsed by P_Name (4.1)
-
- ------------------------
- -- 4.1 Selector Name --
- ------------------------
-
- -- Parsed by P_Name (4.1)
-
- ------------------------------
- -- 4.1 Attribute Reference --
- ------------------------------
-
- -- Parsed by P_Name (4.1)
-
- -------------------------------
- -- 4.1 Attribute Designator --
- -------------------------------
-
- -- Parsed by P_Name (4.1)
-
- --------------------------------------
- -- 4.1.4 Range Attribute Reference --
- --------------------------------------
-
- -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
-
- -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
-
- -- In the grammar, a RANGE attribute is simply a name, but its use is
- -- highly restricted, so in the parser, we do not regard it as a name.
- -- Instead, P_Name returns without scanning the 'RANGE part of the
- -- attribute, and the caller uses the following function to construct
- -- a range attribute in places where it is appropriate.
-
- -- Note that RANGE here is treated essentially as an identifier,
- -- rather than a reserved word.
-
- -- The caller has parsed the prefix, i.e. a name, and Token points to
- -- the apostrophe. The token after the apostrophe is known to be RANGE
- -- at this point. The prefix node becomes the prefix of the attribute.
-
- -- Error_Recovery: Cannot raise Error_Resync
-
- function P_Range_Attribute_Reference
- (Prefix_Node : Node_Id)
- return Node_Id
- is
- Attr_Node : Node_Id;
-
- begin
- Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
- Set_Prefix (Attr_Node, Prefix_Node);
- Scan; -- past apostrophe
-
- if Style_Check then
- Style.Check_Attribute_Name (True);
- end if;
-
- Set_Attribute_Name (Attr_Node, Name_Range);
- Scan; -- past RANGE
-
- if Token = Tok_Left_Paren then
- Scan; -- past left paren
- Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
- T_Right_Paren;
- end if;
-
- return Attr_Node;
- end P_Range_Attribute_Reference;
-
- ---------------------------------------
- -- 4.1.4 Range Attribute Designator --
- ---------------------------------------
-
- -- Parsed by P_Range_Attribute_Reference (4.4)
-
- --------------------
- -- 4.3 Aggregate --
- --------------------
-
- -- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
- -- an aggregate is known to be required (code statement, extension
- -- aggregate), in which cases this routine performs the necessary check
- -- that we have an aggregate rather than a parenthesized expression
-
- -- Error recovery: can raise Error_Resync
-
- function P_Aggregate return Node_Id is
- Aggr_Sloc : constant Source_Ptr := Token_Ptr;
- Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr;
-
- begin
- if Nkind (Aggr_Node) /= N_Aggregate
- and then
- Nkind (Aggr_Node) /= N_Extension_Aggregate
- then
- Error_Msg
- ("aggregate may not have single positional component", Aggr_Sloc);
- return Error;
- else
- return Aggr_Node;
- end if;
- end P_Aggregate;
-
- ------------------------------------------------
- -- 4.3 Aggregate or Parenthesized Expression --
- ------------------------------------------------
-
- -- This procedure parses out either an aggregate or a parenthesized
- -- expression (these two constructs are closely related, since a
- -- parenthesized expression looks like an aggregate with a single
- -- positional component).
-
- -- AGGREGATE ::=
- -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
-
- -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
-
- -- RECORD_COMPONENT_ASSOCIATION_LIST ::=
- -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
- -- | null record
-
- -- RECORD_COMPONENT_ASSOCIATION ::=
- -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
-
- -- COMPONENT_CHOICE_LIST ::=
- -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
- -- | others
-
- -- EXTENSION_AGGREGATE ::=
- -- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
-
- -- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
-
- -- ARRAY_AGGREGATE ::=
- -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
-
- -- POSITIONAL_ARRAY_AGGREGATE ::=
- -- (EXPRESSION, EXPRESSION {, EXPRESSION})
- -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
- -- | (EXPRESSION {, EXPRESSION}, others => <>)
-
- -- NAMED_ARRAY_AGGREGATE ::=
- -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
-
- -- PRIMARY ::= (EXPRESSION);
-
- -- Error recovery: can raise Error_Resync
-
- -- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
- -- to Ada 2005 limited aggregates (AI-287)
-
- function P_Aggregate_Or_Paren_Expr return Node_Id is
- Aggregate_Node : Node_Id;
- Expr_List : List_Id;
- Assoc_List : List_Id;
- Expr_Node : Node_Id;
- Lparen_Sloc : Source_Ptr;
- Scan_State : Saved_Scan_State;
-
- procedure Box_Error;
- -- Called if <> is encountered as positional aggregate element. Issues
- -- error message and sets Expr_Node to Error.
-
- ---------------
- -- Box_Error --
- ---------------
-
- procedure Box_Error is
- begin
- if Ada_Version < Ada_2005 then
- Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
- end if;
-
- -- Ada 2005 (AI-287): The box notation is allowed only with named
- -- notation because positional notation might be error prone. For
- -- example, in "(X, <>, Y, <>)", there is no type associated with
- -- the boxes, so you might not be leaving out the components you
- -- thought you were leaving out.
-
- Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
- Scan; -- past box
- Expr_Node := Error;
- end Box_Error;
-
- -- Start of processing for P_Aggregate_Or_Paren_Expr
-
- begin
- Lparen_Sloc := Token_Ptr;
- T_Left_Paren;
-
- -- Note on parentheses count. For cases like an if expression, the
- -- parens here really count as real parentheses for the paren count,
- -- so we adjust the paren count accordingly after scanning the expr.
-
- -- If expression
-
- if Token = Tok_If then
- Expr_Node := P_If_Expression;
- T_Right_Paren;
- Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
- return Expr_Node;
-
- -- Case expression
-
- elsif Token = Tok_Case then
- Expr_Node := P_Case_Expression;
- T_Right_Paren;
- Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
- return Expr_Node;
-
- -- Quantified expression
-
- elsif Token = Tok_For then
- Expr_Node := P_Quantified_Expression;
- T_Right_Paren;
- Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
- return Expr_Node;
-
- -- Note: the mechanism used here of rescanning the initial expression
- -- is distinctly unpleasant, but it saves a lot of fiddling in scanning
- -- out the discrete choice list.
-
- -- Deal with expression and extension aggregates first
-
- elsif Token /= Tok_Others then
- Save_Scan_State (Scan_State); -- at start of expression
-
- -- Deal with (NULL RECORD)
-
- if Token = Tok_Null then
- Scan; -- past NULL
-
- if Token = Tok_Record then
- Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
- Set_Null_Record_Present (Aggregate_Node, True);
- Scan; -- past RECORD
- T_Right_Paren;
- return Aggregate_Node;
- else
- Restore_Scan_State (Scan_State); -- to NULL that must be expr
- end if;
- end if;
-
- -- Scan expression, handling box appearing as positional argument
-
- if Token = Tok_Box then
- Box_Error;
- else
- Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
- end if;
-
- -- Extension aggregate
-
- if Token = Tok_With then
- if Nkind (Expr_Node) = N_Attribute_Reference
- and then Attribute_Name (Expr_Node) = Name_Range
- then
- Bad_Range_Attribute (Sloc (Expr_Node));
- return Error;
- end if;
-
- if Ada_Version = Ada_83 then
- Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
- end if;
-
- Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
- Set_Ancestor_Part (Aggregate_Node, Expr_Node);
- Scan; -- past WITH
-
- -- Deal with WITH NULL RECORD case
-
- if Token = Tok_Null then
- Save_Scan_State (Scan_State); -- at NULL
- Scan; -- past NULL
-
- if Token = Tok_Record then
- Scan; -- past RECORD
- Set_Null_Record_Present (Aggregate_Node, True);
- T_Right_Paren;
- return Aggregate_Node;
-
- else
- Restore_Scan_State (Scan_State); -- to NULL that must be expr
- end if;
- end if;
-
- if Token /= Tok_Others then
- Save_Scan_State (Scan_State);
- Expr_Node := P_Expression;
- else
- Expr_Node := Empty;
- end if;
-
- -- Expression
-
- elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
- if Nkind (Expr_Node) = N_Attribute_Reference
- and then Attribute_Name (Expr_Node) = Name_Range
- then
- Error_Msg
- ("|parentheses not allowed for range attribute", Lparen_Sloc);
- Scan; -- past right paren
- return Expr_Node;
- end if;
-
- -- Bump paren count of expression
-
- if Expr_Node /= Error then
- Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
- end if;
-
- T_Right_Paren; -- past right paren (error message if none)
- return Expr_Node;
-
- -- Normal aggregate
-
- else
- Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
- end if;
-
- -- Others
-
- else
- Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
- Expr_Node := Empty;
- end if;
-
- -- Prepare to scan list of component associations
-
- Expr_List := No_List; -- don't set yet, maybe all named entries
- Assoc_List := No_List; -- don't set yet, maybe all positional entries
-
- -- This loop scans through component associations. On entry to the
- -- loop, an expression has been scanned at the start of the current
- -- association unless initial token was OTHERS, in which case
- -- Expr_Node is set to Empty.
-
- loop
- -- Deal with others association first. This is a named association
-
- if No (Expr_Node) then
- if No (Assoc_List) then
- Assoc_List := New_List;
- end if;
-
- Append (P_Record_Or_Array_Component_Association, Assoc_List);
-
- -- Improper use of WITH
-
- elsif Token = Tok_With then
- Error_Msg_SC ("WITH must be preceded by single expression in " &
- "extension aggregate");
- raise Error_Resync;
-
- -- Range attribute can only appear as part of a discrete choice list
-
- elsif Nkind (Expr_Node) = N_Attribute_Reference
- and then Attribute_Name (Expr_Node) = Name_Range
- and then Token /= Tok_Arrow
- and then Token /= Tok_Vertical_Bar
- then
- Bad_Range_Attribute (Sloc (Expr_Node));
- return Error;
-
- -- Assume positional case if comma, right paren, or literal or
- -- identifier or OTHERS follows (the latter cases are missing
- -- comma cases). Also assume positional if a semicolon follows,
- -- which can happen if there are missing parens
-
- elsif Token = Tok_Comma
- or else Token = Tok_Right_Paren
- or else Token = Tok_Others
- or else Token in Token_Class_Lit_Or_Name
- or else Token = Tok_Semicolon
- then
- if Present (Assoc_List) then
- Error_Msg_BC -- CODEFIX
- ("""='>"" expected (positional association cannot follow " &
- "named association)");
- end if;
-
- if No (Expr_List) then
- Expr_List := New_List;
- end if;
-
- Append (Expr_Node, Expr_List);
-
- -- Check for aggregate followed by left parent, maybe missing comma
-
- elsif Nkind (Expr_Node) = N_Aggregate
- and then Token = Tok_Left_Paren
- then
- T_Comma;
-
- if No (Expr_List) then
- Expr_List := New_List;
- end if;
-
- Append (Expr_Node, Expr_List);
-
- -- Anything else is assumed to be a named association
-
- else
- Restore_Scan_State (Scan_State); -- to start of expression
-
- if No (Assoc_List) then
- Assoc_List := New_List;
- end if;
-
- Append (P_Record_Or_Array_Component_Association, Assoc_List);
- end if;
-
- exit when not Comma_Present;
-
- -- If we are at an expression terminator, something is seriously
- -- wrong, so let's get out now, before we start eating up stuff
- -- that doesn't belong to us!
-
- if Token in Token_Class_Eterm then
- Error_Msg_AP
- ("expecting expression or component association");
- exit;
- end if;
-
- -- Deal with misused box
-
- if Token = Tok_Box then
- Box_Error;
-
- -- Otherwise initiate for reentry to top of loop by scanning an
- -- initial expression, unless the first token is OTHERS.
-
- elsif Token = Tok_Others then
- Expr_Node := Empty;
-
- else
- Save_Scan_State (Scan_State); -- at start of expression
- Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
-
- end if;
- end loop;
-
- -- All component associations (positional and named) have been scanned
-
- T_Right_Paren;
- Set_Expressions (Aggregate_Node, Expr_List);
- Set_Component_Associations (Aggregate_Node, Assoc_List);
- return Aggregate_Node;
- end P_Aggregate_Or_Paren_Expr;
-
- ------------------------------------------------
- -- 4.3 Record or Array Component Association --
- ------------------------------------------------
-
- -- RECORD_COMPONENT_ASSOCIATION ::=
- -- [COMPONENT_CHOICE_LIST =>] EXPRESSION
- -- | COMPONENT_CHOICE_LIST => <>
-
- -- COMPONENT_CHOICE_LIST =>
- -- component_SELECTOR_NAME {| component_SELECTOR_NAME}
- -- | others
-
- -- ARRAY_COMPONENT_ASSOCIATION ::=
- -- DISCRETE_CHOICE_LIST => EXPRESSION
- -- | DISCRETE_CHOICE_LIST => <>
-
- -- Note: this routine only handles the named cases, including others.
- -- Cases where the component choice list is not present have already
- -- been handled directly.
-
- -- Error recovery: can raise Error_Resync
-
- -- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
- -- rules have been extended to give support to Ada 2005 limited
- -- aggregates (AI-287)
-
- function P_Record_Or_Array_Component_Association return Node_Id is
- Assoc_Node : Node_Id;
-
- begin
- Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
- Set_Choices (Assoc_Node, P_Discrete_Choice_List);
- Set_Sloc (Assoc_Node, Token_Ptr);
- TF_Arrow;
-
- if Token = Tok_Box then
-
- -- Ada 2005(AI-287): The box notation is used to indicate the
- -- default initialization of aggregate components
-
- if Ada_Version < Ada_2005 then
- Error_Msg_SP
- ("component association with '<'> is an Ada 2005 extension");
- Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
- end if;
-
- Set_Box_Present (Assoc_Node);
- Scan; -- Past box
- else
- Set_Expression (Assoc_Node, P_Expression);
- end if;
-
- return Assoc_Node;
- end P_Record_Or_Array_Component_Association;
-
- -----------------------------
- -- 4.3.1 Record Aggregate --
- -----------------------------
-
- -- Case of enumeration aggregate is parsed by P_Aggregate (4.3)
- -- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ----------------------------------------------
- -- 4.3.1 Record Component Association List --
- ----------------------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ----------------------------------
- -- 4.3.1 Component Choice List --
- ----------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- --------------------------------
- -- 4.3.1 Extension Aggregate --
- --------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- --------------------------
- -- 4.3.1 Ancestor Part --
- --------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ----------------------------
- -- 4.3.1 Array Aggregate --
- ----------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ---------------------------------------
- -- 4.3.1 Positional Array Aggregate --
- ---------------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ----------------------------------
- -- 4.3.1 Named Array Aggregate --
- ----------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ----------------------------------------
- -- 4.3.1 Array Component Association --
- ----------------------------------------
-
- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
-
- ---------------------
- -- 4.4 Expression --
- ---------------------
-
- -- This procedure parses EXPRESSION or CHOICE_EXPRESSION
-
- -- EXPRESSION ::=
- -- RELATION {LOGICAL_OPERATOR RELATION}
-
- -- CHOICE_EXPRESSION ::=
- -- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
-
- -- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
-
- -- On return, Expr_Form indicates the categorization of the expression
- -- EF_Range_Attr is not a possible value (if a range attribute is found,
- -- an error message is given, and Error is returned).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Expression return Node_Id is
- Logical_Op : Node_Kind;
- Prev_Logical_Op : Node_Kind;
- Op_Location : Source_Ptr;
- Node1 : Node_Id;
- Node2 : Node_Id;
-
- begin
- Node1 := P_Relation;
-
- if Token in Token_Class_Logop then
- Prev_Logical_Op := N_Empty;
-
- loop
- Op_Location := Token_Ptr;
- Logical_Op := P_Logical_Operator;
-
- if Prev_Logical_Op /= N_Empty and then
- Logical_Op /= Prev_Logical_Op
- then
- Error_Msg
- ("mixed logical operators in expression", Op_Location);
- Prev_Logical_Op := N_Empty;
- else
- Prev_Logical_Op := Logical_Op;
- end if;
-
- Node2 := Node1;
- Node1 := New_Op_Node (Logical_Op, Op_Location);
- Set_Left_Opnd (Node1, Node2);
- Set_Right_Opnd (Node1, P_Relation);
- exit when Token not in Token_Class_Logop;
- end loop;
-
- Expr_Form := EF_Non_Simple;
- end if;
-
- if Token = Tok_Apostrophe then
- Bad_Range_Attribute (Token_Ptr);
- return Error;
- else
- return Node1;
- end if;
- end P_Expression;
-
- -- This function is identical to the normal P_Expression, except that it
- -- also permits the appearance of a case, conditional, or quantified
- -- expression if the call immediately follows a left paren, and followed
- -- by a right parenthesis. These forms are allowed if these conditions
- -- are not met, but an error message will be issued.
-
- function P_Expression_If_OK return Node_Id 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;
-
- -- Normal case, not case/conditional/quantified expression
-
- else
- return P_Expression;
- end if;
- end P_Expression_If_OK;
-
- -- This function is identical to the normal P_Expression, except that it
- -- checks that the expression scan did not stop on a right paren. It is
- -- called in all contexts where a right parenthesis cannot legitimately
- -- follow an expression.
-
- -- Error recovery: can not raise Error_Resync
-
- function P_Expression_No_Right_Paren return Node_Id is
- Expr : constant Node_Id := P_Expression;
- begin
- Ignore (Tok_Right_Paren);
- return Expr;
- end P_Expression_No_Right_Paren;
-
- ----------------------------------------
- -- 4.4 Expression_Or_Range_Attribute --
- ----------------------------------------
-
- -- EXPRESSION ::=
- -- RELATION {and RELATION} | RELATION {and then RELATION}
- -- | RELATION {or RELATION} | RELATION {or else RELATION}
- -- | RELATION {xor RELATION}
-
- -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
-
- -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
-
- -- On return, Expr_Form indicates the categorization of the expression
- -- and EF_Range_Attr is one of the possibilities.
-
- -- Error recovery: cannot raise Error_Resync
-
- -- In the grammar, a RANGE attribute is simply a name, but its use is
- -- highly restricted, so in the parser, we do not regard it as a name.
- -- Instead, P_Name returns without scanning the 'RANGE part of the
- -- attribute, and P_Expression_Or_Range_Attribute handles the range
- -- attribute reference. In the normal case where a range attribute is
- -- not allowed, an error message is issued by P_Expression.
-
- function P_Expression_Or_Range_Attribute return Node_Id is
- Logical_Op : Node_Kind;
- Prev_Logical_Op : Node_Kind;
- Op_Location : Source_Ptr;
- Node1 : Node_Id;
- Node2 : Node_Id;
- Attr_Node : Node_Id;
-
- begin
- Node1 := P_Relation;
-
- if Token = Tok_Apostrophe then
- Attr_Node := P_Range_Attribute_Reference (Node1);
- Expr_Form := EF_Range_Attr;
- return Attr_Node;
-
- elsif Token in Token_Class_Logop then
- Prev_Logical_Op := N_Empty;
-
- loop
- Op_Location := Token_Ptr;
- Logical_Op := P_Logical_Operator;
-
- if Prev_Logical_Op /= N_Empty and then
- Logical_Op /= Prev_Logical_Op
- then
- Error_Msg
- ("mixed logical operators in expression", Op_Location);
- Prev_Logical_Op := N_Empty;
- else
- Prev_Logical_Op := Logical_Op;
- end if;
-
- Node2 := Node1;
- Node1 := New_Op_Node (Logical_Op, Op_Location);
- Set_Left_Opnd (Node1, Node2);
- Set_Right_Opnd (Node1, P_Relation);
- exit when Token not in Token_Class_Logop;
- end loop;
-
- Expr_Form := EF_Non_Simple;
- end if;
-
- if Token = Tok_Apostrophe then
- Bad_Range_Attribute (Token_Ptr);
- return Error;
- else
- return Node1;
- end if;
- end P_Expression_Or_Range_Attribute;
-
- -- Version that allows a non-parenthesized case, conditional, or quantified
- -- expression if the call immediately follows a left paren, and followed
- -- by a right parenthesis. These forms are allowed if these conditions
- -- are not met, but an error message will be issued.
-
- function P_Expression_Or_Range_Attribute_If_OK return Node_Id 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;
-
- -- Normal case, not one of the above expression types
-
- else
- return P_Expression_Or_Range_Attribute;
- end if;
- end P_Expression_Or_Range_Attribute_If_OK;
-
- -------------------
- -- 4.4 Relation --
- -------------------
-
- -- This procedure scans both relations and choice relations
-
- -- CHOICE_RELATION ::=
- -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
-
- -- RELATION ::=
- -- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
-
- -- MEMBERSHIP_CHOICE_LIST ::=
- -- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
-
- -- MEMBERSHIP_CHOICE ::=
- -- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
-
- -- On return, Expr_Form indicates the categorization of the expression
-
- -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
- -- EF_Simple_Name and the following token is RANGE (range attribute case).
-
- -- Error recovery: cannot raise Error_Resync. If an error occurs within an
- -- expression, then tokens are scanned until either a non-expression token,
- -- a right paren (not matched by a left paren) or a comma, is encountered.
-
- function P_Relation return Node_Id is
- Node1, Node2 : Node_Id;
- Optok : Source_Ptr;
-
- begin
- Node1 := P_Simple_Expression;
-
- if Token not in Token_Class_Relop then
- return Node1;
-
- else
- -- Here we have a relational operator following. If so then scan it
- -- out. Note that the assignment symbol := is treated as a relational
- -- operator to improve the error recovery when it is misused for =.
- -- P_Relational_Operator also parses the IN and NOT IN operations.
-
- Optok := Token_Ptr;
- Node2 := New_Op_Node (P_Relational_Operator, Optok);
- Set_Left_Opnd (Node2, Node1);
-
- -- Case of IN or NOT IN
-
- if Prev_Token = Tok_In then
- P_Membership_Test (Node2);
-
- -- Case of relational operator (= /= < <= > >=)
-
- else
- Set_Right_Opnd (Node2, P_Simple_Expression);
- end if;
-
- Expr_Form := EF_Non_Simple;
-
- if Token in Token_Class_Relop then
- Error_Msg_SC ("unexpected relational operator");
- raise Error_Resync;
- end if;
-
- return Node2;
- end if;
-
- -- If any error occurs, then scan to the next expression terminator symbol
- -- or comma or right paren at the outer (i.e. current) parentheses level.
- -- The flags are set to indicate a normal simple expression.
-
- exception
- when Error_Resync =>
- Resync_Expression;
- Expr_Form := EF_Simple;
- return Error;
- end P_Relation;
-
- ----------------------------
- -- 4.4 Simple Expression --
- ----------------------------
-
- -- SIMPLE_EXPRESSION ::=
- -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
-
- -- On return, Expr_Form indicates the categorization of the expression
-
- -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to
- -- EF_Simple_Name and the following token is RANGE (range attribute case).
-
- -- Error recovery: cannot raise Error_Resync. If an error occurs within an
- -- expression, then tokens are scanned until either a non-expression token,
- -- a right paren (not matched by a left paren) or a comma, is encountered.
-
- -- Note: P_Simple_Expression is called only internally by higher level
- -- expression routines. In cases in the grammar where a simple expression
- -- is required, the approach is to scan an expression, and then post an
- -- appropriate error message if the expression obtained is not simple. This
- -- gives better error recovery and treatment.
-
- function P_Simple_Expression return Node_Id is
- Scan_State : Saved_Scan_State;
- Node1 : Node_Id;
- Node2 : Node_Id;
- Tokptr : Source_Ptr;
-
- begin
- -- Check for cases starting with a name. There are two reasons for
- -- special casing. First speed things up by catching a common case
- -- without going through several routine layers. Second the caller must
- -- be informed via Expr_Form when the simple expression is a name.
-
- if Token in Token_Class_Name then
- Node1 := P_Name;
-
- -- Deal with apostrophe cases
-
- if Token = Tok_Apostrophe then
- Save_Scan_State (Scan_State); -- at apostrophe
- Scan; -- past apostrophe
-
- -- If qualified expression, scan it out and fall through
-
- if Token = Tok_Left_Paren then
- Node1 := P_Qualified_Expression (Node1);
- Expr_Form := EF_Simple;
-
- -- If range attribute, then we return with Token pointing to the
- -- apostrophe. Note: avoid the normal error check on exit. We
- -- know that the expression really is complete in this case!
-
- else -- Token = Tok_Range then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Expr_Form := EF_Simple_Name;
- return Node1;
- end if;
- end if;
-
- -- If an expression terminator follows, the previous processing
- -- completely scanned out the expression (a common case), and
- -- left Expr_Form set appropriately for returning to our caller.
-
- if Token in Token_Class_Sterm then
- null;
-
- -- If we do not have an expression terminator, then complete the
- -- scan of a simple expression. This code duplicates the code
- -- found in P_Term and P_Factor.
-
- else
- if Token = Tok_Double_Asterisk then
- if Style_Check then
- Style.Check_Exponentiation_Operator;
- end if;
-
- Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
- Scan; -- past **
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Primary);
- Check_Bad_Exp;
- Node1 := Node2;
- end if;
-
- loop
- exit when Token not in Token_Class_Mulop;
- Tokptr := Token_Ptr;
- Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
-
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past operator
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Factor);
- Node1 := Node2;
- end loop;
-
- loop
- exit when Token not in Token_Class_Binary_Addop;
- Tokptr := Token_Ptr;
- Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
-
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past operator
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Term);
- Node1 := Node2;
- end loop;
-
- Expr_Form := EF_Simple;
- end if;
-
- -- Cases where simple expression does not start with a name
-
- else
- -- Scan initial sign and initial Term
-
- if Token in Token_Class_Unary_Addop then
- Tokptr := Token_Ptr;
- Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr);
-
- if Style_Check then
- Style.Check_Unary_Plus_Or_Minus;
- end if;
-
- Scan; -- past operator
- Set_Right_Opnd (Node1, P_Term);
- else
- Node1 := P_Term;
- end if;
-
- -- In the following, we special-case a sequence of concatenations of
- -- string literals, such as "aaa" & "bbb" & ... & "ccc", with nothing
- -- else mixed in. For such a sequence, we return a tree representing
- -- "" & "aaabbb...ccc" (a single concatenation). This is done only if
- -- the number of concatenations is large. If semantic analysis
- -- resolves the "&" to a predefined one, then this folding gives the
- -- right answer. Otherwise, semantic analysis will complain about a
- -- capacity-exceeded error. The purpose of this trick is to avoid
- -- creating a deeply nested tree, which would cause deep recursion
- -- during semantics, causing stack overflow. This way, we can handle
- -- enormous concatenations in the normal case of predefined "&". We
- -- first build up the normal tree, and then rewrite it if
- -- appropriate.
-
- declare
- Num_Concats_Threshold : constant Positive := 1000;
- -- Arbitrary threshold value to enable optimization
-
- First_Node : constant Node_Id := Node1;
- Is_Strlit_Concat : Boolean;
- -- True iff we've parsed a sequence of concatenations of string
- -- literals, with nothing else mixed in.
-
- Num_Concats : Natural;
- -- Number of "&" operators if Is_Strlit_Concat is True
-
- begin
- Is_Strlit_Concat :=
- Nkind (Node1) = N_String_Literal
- and then Token = Tok_Ampersand;
- Num_Concats := 0;
-
- -- Scan out sequence of terms separated by binary adding operators
-
- loop
- exit when Token not in Token_Class_Binary_Addop;
- Tokptr := Token_Ptr;
- Node2 := New_Op_Node (P_Binary_Adding_Operator, Tokptr);
- Scan; -- past operator
- Set_Left_Opnd (Node2, Node1);
- Node1 := P_Term;
- Set_Right_Opnd (Node2, Node1);
-
- -- Check if we're still concatenating string literals
-
- Is_Strlit_Concat :=
- Is_Strlit_Concat
- and then Nkind (Node2) = N_Op_Concat
- and then Nkind (Node1) = N_String_Literal;
-
- if Is_Strlit_Concat then
- Num_Concats := Num_Concats + 1;
- end if;
-
- Node1 := Node2;
- end loop;
-
- -- If we have an enormous series of concatenations of string
- -- literals, rewrite as explained above. The Is_Folded_In_Parser
- -- flag tells semantic analysis that if the "&" is not predefined,
- -- the folded value is wrong.
-
- if Is_Strlit_Concat
- and then Num_Concats >= Num_Concats_Threshold
- then
- declare
- Empty_String_Val : String_Id;
- -- String_Id for ""
-
- Strlit_Concat_Val : String_Id;
- -- Contains the folded value (which will be correct if the
- -- "&" operators are the predefined ones).
-
- Cur_Node : Node_Id;
- -- For walking up the tree
-
- New_Node : Node_Id;
- -- Folded node to replace Node1
-
- Loc : constant Source_Ptr := Sloc (First_Node);
-
- begin
- -- Walk up the tree starting at the leftmost string literal
- -- (First_Node), building up the Strlit_Concat_Val as we
- -- go. Note that we do not use recursion here -- the whole
- -- point is to avoid recursively walking that enormous tree.
-
- Start_String;
- Store_String_Chars (Strval (First_Node));
-
- Cur_Node := Parent (First_Node);
- while Present (Cur_Node) loop
- pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
- Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
-
- Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
- Cur_Node := Parent (Cur_Node);
- end loop;
-
- Strlit_Concat_Val := End_String;
-
- -- Create new folded node, and rewrite result with a concat-
- -- enation of an empty string literal and the folded node.
-
- Start_String;
- Empty_String_Val := End_String;
- New_Node :=
- Make_Op_Concat (Loc,
- Make_String_Literal (Loc, Empty_String_Val),
- Make_String_Literal (Loc, Strlit_Concat_Val,
- Is_Folded_In_Parser => True));
- Rewrite (Node1, New_Node);
- end;
- end if;
- end;
-
- -- All done, we clearly do not have name or numeric literal so this
- -- is a case of a simple expression which is some other possibility.
-
- Expr_Form := EF_Simple;
- end if;
-
- -- Come here at end of simple expression, where we do a couple of
- -- special checks to improve error recovery.
-
- -- Special test to improve error recovery. If the current token
- -- is a period, then someone is trying to do selection on something
- -- that is not a name, e.g. a qualified expression.
-
- 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 Ada_Version < Ada_2012
- and then Nkind (Node1) = N_Qualified_Expression
- then
- Error_Msg_SC ("\would be legal in Ada 2012 mode");
- else
- raise Error_Resync;
- end if;
- end if;
-
- -- Special test to improve error recovery: If the current token is
- -- not the first token on a line (as determined by checking the
- -- previous token position with the start of the current line),
- -- then we insist that we have an appropriate terminating token.
- -- Consider the following two examples:
-
- -- 1) if A nad B then ...
-
- -- 2) A := B
- -- C := D
-
- -- In the first example, we would like to issue a binary operator
- -- expected message and resynchronize to the then. In the second
- -- example, we do not want to issue a binary operator message, so
- -- that instead we will get the missing semicolon message. This
- -- distinction is of course a heuristic which does not always work,
- -- but in practice it is quite effective.
-
- -- Note: the one case in which we do not go through this circuit is
- -- when we have scanned a range attribute and want to return with
- -- Token pointing to the apostrophe. The apostrophe is not normally
- -- an expression terminator, and is not in Token_Class_Sterm, but
- -- in this special case we know that the expression is complete.
-
- if not Token_Is_At_Start_Of_Line
- and then Token not in Token_Class_Sterm
- then
- -- Normally the right error message is indeed that we expected a
- -- binary operator, but in the case of being between a right and left
- -- paren, e.g. in an aggregate, a more likely error is missing comma.
-
- if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
- T_Comma;
- else
- Error_Msg_AP ("binary operator expected");
- end if;
-
- raise Error_Resync;
-
- else
- return Node1;
- end if;
-
- -- If any error occurs, then scan to next expression terminator symbol
- -- or comma, right paren or vertical bar at the outer (i.e. current) paren
- -- level. Expr_Form is set to indicate a normal simple expression.
-
- exception
- when Error_Resync =>
- Resync_Expression;
- Expr_Form := EF_Simple;
- return Error;
- end P_Simple_Expression;
-
- -----------------------------------------------
- -- 4.4 Simple Expression or Range Attribute --
- -----------------------------------------------
-
- -- SIMPLE_EXPRESSION ::=
- -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM}
-
- -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
-
- -- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Simple_Expression_Or_Range_Attribute return Node_Id is
- Sexpr : Node_Id;
- Attr_Node : Node_Id;
-
- begin
- -- We don't just want to roar ahead and call P_Simple_Expression
- -- here, since we want to handle the case of a parenthesized range
- -- attribute cleanly.
-
- if Token = Tok_Left_Paren then
- declare
- Lptr : constant Source_Ptr := Token_Ptr;
- Scan_State : Saved_Scan_State;
-
- begin
- Save_Scan_State (Scan_State);
- Scan; -- past left paren
- Sexpr := P_Simple_Expression;
-
- if Token = Tok_Apostrophe then
- Attr_Node := P_Range_Attribute_Reference (Sexpr);
- Expr_Form := EF_Range_Attr;
-
- if Token = Tok_Right_Paren then
- Scan; -- scan past right paren if present
- end if;
-
- Error_Msg ("parentheses not allowed for range attribute", Lptr);
-
- return Attr_Node;
- end if;
-
- Restore_Scan_State (Scan_State);
- end;
- end if;
-
- -- Here after dealing with parenthesized range attribute
-
- Sexpr := P_Simple_Expression;
-
- if Token = Tok_Apostrophe then
- Attr_Node := P_Range_Attribute_Reference (Sexpr);
- Expr_Form := EF_Range_Attr;
- return Attr_Node;
-
- else
- return Sexpr;
- end if;
- end P_Simple_Expression_Or_Range_Attribute;
-
- ---------------
- -- 4.4 Term --
- ---------------
-
- -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR}
-
- -- Error recovery: can raise Error_Resync
-
- function P_Term return Node_Id is
- Node1, Node2 : Node_Id;
- Tokptr : Source_Ptr;
-
- begin
- Node1 := P_Factor;
-
- loop
- exit when Token not in Token_Class_Mulop;
- Tokptr := Token_Ptr;
- Node2 := New_Op_Node (P_Multiplying_Operator, Tokptr);
- Scan; -- past operator
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Factor);
- Node1 := Node2;
- end loop;
-
- return Node1;
- end P_Term;
-
- -----------------
- -- 4.4 Factor --
- -----------------
-
- -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY
-
- -- Error recovery: can raise Error_Resync
-
- function P_Factor return Node_Id is
- Node1 : Node_Id;
- Node2 : Node_Id;
-
- begin
- if Token = Tok_Abs then
- Node1 := New_Op_Node (N_Op_Abs, Token_Ptr);
-
- if Style_Check then
- Style.Check_Abs_Not;
- end if;
-
- Scan; -- past ABS
- Set_Right_Opnd (Node1, P_Primary);
- return Node1;
-
- elsif Token = Tok_Not then
- Node1 := New_Op_Node (N_Op_Not, Token_Ptr);
-
- if Style_Check then
- Style.Check_Abs_Not;
- end if;
-
- Scan; -- past NOT
- Set_Right_Opnd (Node1, P_Primary);
- return Node1;
-
- else
- Node1 := P_Primary;
-
- if Token = Tok_Double_Asterisk then
- Node2 := New_Op_Node (N_Op_Expon, Token_Ptr);
- Scan; -- past **
- Set_Left_Opnd (Node2, Node1);
- Set_Right_Opnd (Node2, P_Primary);
- Check_Bad_Exp;
- return Node2;
- else
- return Node1;
- end if;
- end if;
- end P_Factor;
-
- ------------------
- -- 4.4 Primary --
- ------------------
-
- -- PRIMARY ::=
- -- NUMERIC_LITERAL | null
- -- | STRING_LITERAL | AGGREGATE
- -- | NAME | QUALIFIED_EXPRESSION
- -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
-
- -- Error recovery: can raise Error_Resync
-
- function P_Primary return Node_Id is
- Scan_State : Saved_Scan_State;
- Node1 : Node_Id;
-
- Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
- -- Remember if previous token is a left parenthesis. This is used to
- -- deal with checking whether IF/CASE/FOR expressions appearing as
- -- primaries require extra parenthesization.
-
- begin
- -- The loop runs more than once only if misplaced pragmas are found
- -- or if a misplaced unary minus is skipped.
-
- loop
- case Token is
-
- -- Name token can start a name, call or qualified expression, all
- -- of which are acceptable possibilities for primary. Note also
- -- that string literal is included in name (as operator symbol)
- -- and type conversion is included in name (as indexed component).
-
- when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
- Node1 := P_Name;
-
- -- All done unless apostrophe follows
-
- if Token /= Tok_Apostrophe then
- return Node1;
-
- -- Apostrophe following means that we have either just parsed
- -- the subtype mark of a qualified expression, or the prefix
- -- or a range attribute.
-
- else -- Token = Tok_Apostrophe
- Save_Scan_State (Scan_State); -- at apostrophe
- Scan; -- past apostrophe
-
- -- If range attribute, then this is always an error, since
- -- the only legitimate case (where the scanned expression is
- -- a qualified simple name) is handled at the level of the
- -- Simple_Expression processing. This case corresponds to a
- -- usage such as 3 + A'Range, which is always illegal.
-
- if Token = Tok_Range then
- Restore_Scan_State (Scan_State); -- to apostrophe
- Bad_Range_Attribute (Token_Ptr);
- return Error;
-
- -- If left paren, then we have a qualified expression.
- -- Note that P_Name guarantees that in this case, where
- -- Token = Tok_Apostrophe on return, the only two possible
- -- tokens following the apostrophe are left paren and
- -- RANGE, so we know we have a left paren here.
-
- else -- Token = Tok_Left_Paren
- return P_Qualified_Expression (Node1);
-
- end if;
- end if;
-
- -- Numeric or string literal
-
- when Tok_Integer_Literal |
- Tok_Real_Literal |
- Tok_String_Literal =>
-
- Node1 := Token_Node;
- Scan; -- past number
- return Node1;
-
- -- Left paren, starts aggregate or parenthesized expression
-
- when Tok_Left_Paren =>
- declare
- Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
-
- begin
- if Nkind (Expr) = N_Attribute_Reference
- and then Attribute_Name (Expr) = Name_Range
- then
- Bad_Range_Attribute (Sloc (Expr));
- end if;
-
- return Expr;
- end;
-
- -- Allocator
-
- when Tok_New =>
- return P_Allocator;
-
- -- Null
-
- when Tok_Null =>
- Scan; -- past NULL
- return New_Node (N_Null, Prev_Token_Ptr);
-
- -- Pragma, not allowed here, so just skip past it
-
- when Tok_Pragma =>
- P_Pragmas_Misplaced;
-
- -- Deal with IF (possible unparenthesized if expression)
-
- when Tok_If =>
-
- -- If this looks like a real if, defined as an IF appearing at
- -- the start of a new line, then we consider we have a missing
- -- operand. If in Ada 2012 and the IF is not properly indented
- -- for a statement, we prefer to issue a message about an ill-
- -- parenthesized if expression.
-
- if Token_Is_At_Start_Of_Line
- and then not
- (Ada_Version >= Ada_2012
- and then Style_Check_Indentation /= 0
- and then Start_Column rem Style_Check_Indentation /= 0)
- then
- Error_Msg_AP ("missing operand");
- return Error;
-
- -- If this looks like an if expression, then treat it that way
- -- with an error message if not explicitly surrounded by
- -- parentheses.
-
- elsif Ada_Version >= Ada_2012 then
- Node1 := P_If_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg
- ("if expression must be parenthesized", Sloc (Node1));
- end if;
-
- return Node1;
-
- -- Otherwise treat as misused identifier
-
- else
- return P_Identifier;
- end if;
-
- -- Deal with CASE (possible unparenthesized case expression)
-
- when Tok_Case =>
-
- -- If this looks like a real case, defined as a CASE appearing
- -- the start of a new line, then we consider we have a missing
- -- operand. If in Ada 2012 and the CASE is not properly
- -- indented for a statement, we prefer to issue a message about
- -- an ill-parenthesized case expression.
-
- if Token_Is_At_Start_Of_Line
- and then not
- (Ada_Version >= Ada_2012
- and then Style_Check_Indentation /= 0
- and then Start_Column rem Style_Check_Indentation /= 0)
- then
- Error_Msg_AP ("missing operand");
- return Error;
-
- -- If this looks like a case expression, then treat it that way
- -- with an error message if not within parentheses.
-
- elsif Ada_Version >= Ada_2012 then
- Node1 := P_Case_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg
- ("case expression must be parenthesized", Sloc (Node1));
- end if;
-
- return Node1;
-
- -- Otherwise treat as misused identifier
-
- else
- return P_Identifier;
- end if;
-
- -- For [all | some] indicates a quantified expression
-
- when Tok_For =>
- if Token_Is_At_Start_Of_Line then
- Error_Msg_AP ("misplaced loop");
- return Error;
-
- elsif Ada_Version >= Ada_2012 then
- Node1 := P_Quantified_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg
- ("quantified expression must be parenthesized",
- Sloc (Node1));
- end if;
-
- return Node1;
-
- -- Otherwise treat as misused identifier
-
- else
- return P_Identifier;
- end if;
-
- -- Minus may well be an improper attempt at a unary minus. Give
- -- a message, skip the minus and keep going!
-
- when Tok_Minus =>
- Error_Msg_SC ("parentheses required for unary minus");
- Scan; -- past minus
-
- -- Anything else is illegal as the first token of a primary, but
- -- we test for some common errors, to improve error messages.
-
- when others =>
- if Is_Reserved_Identifier then
- return P_Identifier;
-
- elsif Prev_Token = Tok_Comma then
- Error_Msg_SP -- CODEFIX
- ("|extra "","" ignored");
- raise Error_Resync;
-
- else
- Error_Msg_AP ("missing operand");
- raise Error_Resync;
- end if;
-
- end case;
- end loop;
- end P_Primary;
-
- -------------------------------
- -- 4.4 Quantified_Expression --
- -------------------------------
-
- -- QUANTIFIED_EXPRESSION ::=
- -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
- -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
-
- function P_Quantified_Expression return Node_Id is
- I_Spec : Node_Id;
- Node1 : Node_Id;
-
- begin
- if Ada_Version < Ada_2012 then
- Error_Msg_SC ("quantified expression is an Ada 2012 feature");
- Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
- end if;
-
- Scan; -- past FOR
-
- Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
-
- if Token = Tok_All then
- Set_All_Present (Node1);
-
- elsif Token /= Tok_Some then
- Error_Msg_AP ("missing quantifier");
- raise Error_Resync;
- end if;
-
- Scan; -- past SOME
- I_Spec := P_Loop_Parameter_Specification;
-
- if Nkind (I_Spec) = N_Loop_Parameter_Specification then
- Set_Loop_Parameter_Specification (Node1, I_Spec);
- else
- Set_Iterator_Specification (Node1, I_Spec);
- end if;
-
- if Token = Tok_Arrow then
- Scan;
- Set_Condition (Node1, P_Expression);
- return Node1;
- else
- Error_Msg_AP ("missing arrow");
- raise Error_Resync;
- end if;
- end P_Quantified_Expression;
-
- ---------------------------
- -- 4.5 Logical Operator --
- ---------------------------
-
- -- LOGICAL_OPERATOR ::= and | or | xor
-
- -- Note: AND THEN and OR ELSE are also treated as logical operators
- -- by the parser (even though they are not operators semantically)
-
- -- The value returned is the appropriate Node_Kind code for the operator
- -- On return, Token points to the token following the scanned operator.
-
- -- The caller has checked that the first token is a legitimate logical
- -- operator token (i.e. is either XOR, AND, OR).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Logical_Operator return Node_Kind is
- begin
- if Token = Tok_And then
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past AND
-
- if Token = Tok_Then then
- Scan; -- past THEN
- return N_And_Then;
- else
- return N_Op_And;
- end if;
-
- elsif Token = Tok_Or then
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past OR
-
- if Token = Tok_Else then
- Scan; -- past ELSE
- return N_Or_Else;
- else
- return N_Op_Or;
- end if;
-
- else -- Token = Tok_Xor
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past XOR
- return N_Op_Xor;
- end if;
- end P_Logical_Operator;
-
- ------------------------------
- -- 4.5 Relational Operator --
- ------------------------------
-
- -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >=
-
- -- The value returned is the appropriate Node_Kind code for the operator.
- -- On return, Token points to the operator token, NOT past it.
-
- -- The caller has checked that the first token is a legitimate relational
- -- operator token (i.e. is one of the operator tokens listed above).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Relational_Operator return Node_Kind is
- Op_Kind : Node_Kind;
- Relop_Node : constant array (Token_Class_Relop) of Node_Kind :=
- (Tok_Less => N_Op_Lt,
- Tok_Equal => N_Op_Eq,
- Tok_Greater => N_Op_Gt,
- Tok_Not_Equal => N_Op_Ne,
- Tok_Greater_Equal => N_Op_Ge,
- Tok_Less_Equal => N_Op_Le,
- Tok_In => N_In,
- Tok_Not => N_Not_In,
- Tok_Box => N_Op_Ne);
-
- begin
- if Token = Tok_Box then
- Error_Msg_SC -- CODEFIX
- ("|""'<'>"" should be ""/=""");
- end if;
-
- Op_Kind := Relop_Node (Token);
-
- if Style_Check then
- Style.Check_Binary_Operator;
- end if;
-
- Scan; -- past operator token
-
- -- Deal with NOT IN, if previous token was NOT, we must have IN now
-
- if Prev_Token = Tok_Not then
-
- -- Style check, for NOT IN, we require one space between NOT and IN
-
- if Style_Check and then Token = Tok_In then
- Style.Check_Not_In;
- end if;
-
- T_In;
- end if;
-
- return Op_Kind;
- end P_Relational_Operator;
-
- ---------------------------------
- -- 4.5 Binary Adding Operator --
- ---------------------------------
-
- -- BINARY_ADDING_OPERATOR ::= + | - | &
-
- -- The value returned is the appropriate Node_Kind code for the operator.
- -- On return, Token points to the operator token (NOT past it).
-
- -- The caller has checked that the first token is a legitimate adding
- -- operator token (i.e. is one of the operator tokens listed above).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Binary_Adding_Operator return Node_Kind is
- Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind :=
- (Tok_Ampersand => N_Op_Concat,
- Tok_Minus => N_Op_Subtract,
- Tok_Plus => N_Op_Add);
- begin
- return Addop_Node (Token);
- end P_Binary_Adding_Operator;
-
- --------------------------------
- -- 4.5 Unary Adding Operator --
- --------------------------------
-
- -- UNARY_ADDING_OPERATOR ::= + | -
-
- -- The value returned is the appropriate Node_Kind code for the operator.
- -- On return, Token points to the operator token (NOT past it).
-
- -- The caller has checked that the first token is a legitimate adding
- -- operator token (i.e. is one of the operator tokens listed above).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Unary_Adding_Operator return Node_Kind is
- Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind :=
- (Tok_Minus => N_Op_Minus,
- Tok_Plus => N_Op_Plus);
- begin
- return Addop_Node (Token);
- end P_Unary_Adding_Operator;
-
- -------------------------------
- -- 4.5 Multiplying Operator --
- -------------------------------
-
- -- MULTIPLYING_OPERATOR ::= * | / | mod | rem
-
- -- The value returned is the appropriate Node_Kind code for the operator.
- -- On return, Token points to the operator token (NOT past it).
-
- -- The caller has checked that the first token is a legitimate multiplying
- -- operator token (i.e. is one of the operator tokens listed above).
-
- -- Error recovery: cannot raise Error_Resync
-
- function P_Multiplying_Operator return Node_Kind is
- Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind :=
- (Tok_Asterisk => N_Op_Multiply,
- Tok_Mod => N_Op_Mod,
- Tok_Rem => N_Op_Rem,
- Tok_Slash => N_Op_Divide);
- begin
- return Mulop_Node (Token);
- end P_Multiplying_Operator;
-
- --------------------------------------
- -- 4.5 Highest Precedence Operator --
- --------------------------------------
-
- -- Parsed by P_Factor (4.4)
-
- -- Note: this rule is not in fact used by the grammar at any point!
-
- --------------------------
- -- 4.6 Type Conversion --
- --------------------------
-
- -- Parsed by P_Primary as a Name (4.1)
-
- -------------------------------
- -- 4.7 Qualified Expression --
- -------------------------------
-
- -- QUALIFIED_EXPRESSION ::=
- -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE
-
- -- The caller has scanned the name which is the Subtype_Mark parameter
- -- and scanned past the single quote following the subtype mark. The
- -- caller has not checked that this name is in fact appropriate for
- -- a subtype mark name (i.e. it is a selected component or identifier).
-
- -- Error_Recovery: cannot raise Error_Resync
-
- function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is
- Qual_Node : Node_Id;
- begin
- Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr);
- Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark));
- Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr);
- return Qual_Node;
- end P_Qualified_Expression;
-
- --------------------
- -- 4.8 Allocator --
- --------------------
-
- -- ALLOCATOR ::=
- -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
- -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
- --
- -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
-
- -- The caller has checked that the initial token is NEW
-
- -- Error recovery: can raise Error_Resync
-
- function P_Allocator return Node_Id is
- Alloc_Node : Node_Id;
- Type_Node : Node_Id;
- Null_Exclusion_Present : Boolean;
-
- begin
- Alloc_Node := New_Node (N_Allocator, Token_Ptr);
- T_New;
-
- -- Scan subpool_specification if present (Ada 2012 (AI05-0111-3))
-
- -- Scan Null_Exclusion if present (Ada 2005 (AI-231))
-
- if Token = Tok_Left_Paren then
- Scan; -- past (
- Set_Subpool_Handle_Name (Alloc_Node, P_Name);
- T_Right_Paren;
-
- if Ada_Version < Ada_2012 then
- Error_Msg_N
- ("|subpool specification is an Ada 2012 feature",
- Subpool_Handle_Name (Alloc_Node));
- Error_Msg_N
- ("\|unit must be compiled with -gnat2012 switch",
- Subpool_Handle_Name (Alloc_Node));
- end if;
- end if;
-
- Null_Exclusion_Present := P_Null_Exclusion;
- Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
- Type_Node := P_Subtype_Mark_Resync;
-
- if Token = Tok_Apostrophe then
- Scan; -- past apostrophe
- Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node));
- else
- Set_Expression
- (Alloc_Node,
- P_Subtype_Indication (Type_Node, Null_Exclusion_Present));
-
- -- AI05-0104: An explicit null exclusion is not allowed for an
- -- allocator without initialization. In previous versions of the
- -- language it just raises constraint error.
-
- if Ada_Version >= Ada_2012 and then Null_Exclusion_Present then
- Error_Msg_N
- ("an allocator with a subtype indication "
- & "cannot have a null exclusion", Alloc_Node);
- end if;
- end if;
-
- return Alloc_Node;
- end P_Allocator;
-
- -----------------------
- -- P_Case_Expression --
- -----------------------
-
- function P_Case_Expression return Node_Id is
- Loc : constant Source_Ptr := Token_Ptr;
- Case_Node : Node_Id;
- Save_State : Saved_Scan_State;
-
- begin
- if Ada_Version < Ada_2012 then
- Error_Msg_SC ("|case expression is an Ada 2012 feature");
- Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
- end if;
-
- Scan; -- past CASE
- Case_Node :=
- Make_Case_Expression (Loc,
- Expression => P_Expression_No_Right_Paren,
- Alternatives => New_List);
- T_Is;
-
- -- We now have scanned out CASE expression IS, scan alternatives
-
- loop
- T_When;
- Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
-
- -- Missing comma if WHEN (more alternatives present)
-
- if Token = Tok_When then
- T_Comma;
-
- -- If comma/WHEN, skip comma and we have another alternative
-
- elsif Token = Tok_Comma then
- Save_Scan_State (Save_State);
- Scan; -- past comma
-
- if Token /= Tok_When then
- Restore_Scan_State (Save_State);
- exit;
- end if;
-
- -- If no comma or WHEN, definitely done
-
- else
- exit;
- end if;
- end loop;
-
- -- If we have an END CASE, diagnose as not needed
-
- if Token = Tok_End then
- Error_Msg_SC ("`END CASE` not allowed at end of case expression");
- Scan; -- past END
-
- if Token = Tok_Case then
- Scan; -- past CASE;
- end if;
- end if;
-
- -- Return the Case_Expression node
-
- return Case_Node;
- end P_Case_Expression;
-
- -----------------------------------
- -- P_Case_Expression_Alternative --
- -----------------------------------
-
- -- CASE_STATEMENT_ALTERNATIVE ::=
- -- when DISCRETE_CHOICE_LIST =>
- -- EXPRESSION
-
- -- The caller has checked that and scanned past the initial WHEN token
- -- Error recovery: can raise Error_Resync
-
- function P_Case_Expression_Alternative return Node_Id is
- Case_Alt_Node : Node_Id;
- begin
- Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
- Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
- TF_Arrow;
- Set_Expression (Case_Alt_Node, P_Expression);
- return Case_Alt_Node;
- end P_Case_Expression_Alternative;
-
- ---------------------
- -- P_If_Expression --
- ---------------------
-
- function P_If_Expression return Node_Id is
- Exprs : constant List_Id := New_List;
- Loc : constant Source_Ptr := Token_Ptr;
- Expr : Node_Id;
- State : Saved_Scan_State;
-
- begin
- Inside_If_Expression := Inside_If_Expression + 1;
-
- if Token = Tok_If and then Ada_Version < Ada_2012 then
- Error_Msg_SC ("|if expression is an Ada 2012 feature");
- Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
- end if;
-
- Scan; -- past IF or ELSIF
- Append_To (Exprs, P_Condition);
- TF_Then;
- Append_To (Exprs, P_Expression);
-
- -- We now have scanned out IF expr THEN expr
-
- -- Check for common error of semicolon before the ELSE
-
- if Token = Tok_Semicolon then
- Save_Scan_State (State);
- Scan; -- past semicolon
-
- if Token = Tok_Else or else Token = Tok_Elsif then
- Error_Msg_SP -- CODEFIX
- ("|extra "";"" ignored");
-
- else
- Restore_Scan_State (State);
- end if;
- end if;
-
- -- Scan out ELSIF sequence if present
-
- if Token = Tok_Elsif then
- Expr := P_If_Expression;
- Set_Is_Elsif (Expr);
- Append_To (Exprs, Expr);
-
- -- Scan out ELSE phrase if present
-
- elsif Token = Tok_Else then
-
- -- Scan out ELSE expression
-
- Scan; -- Past ELSE
- Append_To (Exprs, P_Expression);
-
- -- Two expression case (implied True, filled in during semantics)
-
- else
- null;
- end if;
-
- -- If we have an END IF, diagnose as not needed
-
- if Token = Tok_End then
- Error_Msg_SC ("`END IF` not allowed at end of if expression");
- Scan; -- past END
-
- if Token = Tok_If then
- Scan; -- past IF;
- end if;
- end if;
-
- Inside_If_Expression := Inside_If_Expression - 1;
-
- -- Return the If_Expression node
-
- return
- Make_If_Expression (Loc,
- Expressions => Exprs);
- end P_If_Expression;
-
- -----------------------
- -- P_Membership_Test --
- -----------------------
-
- -- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
- -- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
-
- procedure P_Membership_Test (N : Node_Id) is
- Alt : constant Node_Id :=
- P_Range_Or_Subtype_Mark
- (Allow_Simple_Expression => (Ada_Version >= Ada_2012));
-
- begin
- -- Set case
-
- if Token = Tok_Vertical_Bar then
- if Ada_Version < Ada_2012 then
- Error_Msg_SC ("set notation is an Ada 2012 feature");
- Error_Msg_SC ("\|unit must be compiled with -gnat2012 switch");
- end if;
-
- Set_Alternatives (N, New_List (Alt));
- Set_Right_Opnd (N, Empty);
-
- -- Loop to accumulate alternatives
-
- while Token = Tok_Vertical_Bar loop
- Scan; -- past vertical bar
- Append_To
- (Alternatives (N),
- P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True));
- end loop;
-
- -- Not set case
-
- else
- Set_Right_Opnd (N, Alt);
- Set_Alternatives (N, No_List);
- end if;
- end P_Membership_Test;
-
- ------------------------------------------
- -- P_Unparen_Cond_Case_Quant_Expression --
- ------------------------------------------
-
- function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
- Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
- Result : Node_Id;
-
- begin
- -- Case expression
-
- if Token = Tok_Case then
- Result := P_Case_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg_N ("case expression must be parenthesized!", Result);
- end if;
-
- -- If expression
-
- elsif Token = Tok_If then
- Result := P_If_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg_N ("if expression must be parenthesized!", Result);
- end if;
-
- -- Quantified expression
-
- elsif Token = Tok_For then
- Result := P_Quantified_Expression;
-
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg_N
- ("quantified expression must be parenthesized!", Result);
- end if;
-
- -- No other possibility should exist (caller was supposed to check)
-
- else
- raise Program_Error;
- end if;
-
- -- Return expression (possibly after having given message)
-
- return Result;
- end P_Unparen_Cond_Case_Quant_Expression;
-
-end Ch4;