Google Git
Sign in
gnu / gcc / a8404c07e7fca388c02c39077865f7d5fa928430 / . / gcc / ada / par-ch4.adb
blob: 82b09b29bea0afd8b8a4f6394ed1402684b108e1 [file] [log] [blame]
-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R . C H 4 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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_Loop_Entry => True,
Attribute_Old => True,
Attribute_Result => 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: Loop_Entry is in this list because, although it can take an
-- optional argument (the loop name), we can't distinguish that at parse
-- time from the case where no loop name is given and a legitimate index
-- expression is present. So we parse the argument as an indexed component
-- and the semantic analysis sorts out this syntactic ambiguity based on
-- the type and form of the expression.
-- 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_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;
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_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 --
-------------------------
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 | TARGET_NAME
-- 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
-- TARGET_NAME ::= @ (AI12-0125-3: abbreviation for LHS)
-- 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 | 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
-- AI12-0125 : target_name
if Token = Tok_At_Sign then
Scan_Reserved_Identifier (Force_Msg => False);
if Present (Current_Assign_Node) then
Set_Has_Target_Names (Current_Assign_Node);
end if;
end if;
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 followed
-- by '(' or '['.
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 in Tok_Left_Paren | Tok_Left_Bracket
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 in Tok_Left_Paren | 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>>
case Token is
when Tok_Left_Paren =>
Scan; -- past left paren
goto Scan_Name_Extension_Left_Paren;
when Tok_Apostrophe =>
Save_Scan_State (Scan_State); -- at apostrophe
Scan; -- past apostrophe
goto Scan_Name_Extension_Apostrophe;
when Tok_Dot =>
Save_Scan_State (Scan_State); -- at dot
Scan; -- past dot
goto Scan_Name_Extension_Dot;
when others => raise Program_Error;
end case;
-- 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 incorrect 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 in Tok_Left_Paren | Tok_Left_Bracket
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 in Tok_Range | 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 (see documentation
-- of Is_Parameterless_Attribute for further details).
if Token = Tok_Left_Paren
and then not
Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
then
-- 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, and we get
-- better error handling by knowing that in the parser.
if Attr_Name = Name_Update then
Set_Expressions (Name_Node, New_List);
Append (P_Aggregate, Expressions (Name_Node));
-- All other cases of parsing attribute arguments
else
Set_Expressions (Name_Node, New_List);
Scan; -- past left paren
loop
declare
Expr : constant Node_Id := P_Expression_If_OK;
Rnam : Node_Id;
begin
-- Case of => for named notation
if Token = Tok_Arrow then
-- Named notation allowed only for the special
-- case of System'Restriction_Set (No_Dependence =>
-- unit_NAME), in which case construct a parameter
-- assocation node and append to the arguments.
if Attr_Name = Name_Restriction_Set
and then Nkind (Expr) = N_Identifier
and then Chars (Expr) = Name_No_Dependence
then
Scan; -- past arrow
Rnam := P_Name;
Append_To (Expressions (Name_Node),
Make_Parameter_Association (Sloc (Rnam),
Selector_Name => Expr,
Explicit_Actual_Parameter => Rnam));
exit;
-- For all other cases named notation is illegal
else
Error_Msg_SC
("named parameters not permitted "
& "for attributes");
Scan; -- past junk arrow
end if;
-- Here for normal case (not => for named parameter)
else
-- Special handling for 'Image in Ada 2012, where
-- the attribute can be parameterless and its value
-- can be the prefix of a slice. Rewrite name as a
-- slice, Expr is its low bound.
if Token = Tok_Dot_Dot
and then Attr_Name = Name_Image
and then Ada_Version >= Ada_2012
then
Set_Expressions (Name_Node, No_List);
Prefix_Node := Name_Node;
Name_Node :=
New_Node (N_Slice, Sloc (Prefix_Node));
Set_Prefix (Name_Node, Prefix_Node);
Range_Node := New_Node (N_Range, Token_Ptr);
Set_Low_Bound (Range_Node, Expr);
Scan; -- past ..
Expr_Node := P_Expression;
Check_Simple_Expression (Expr_Node);
Set_High_Bound (Range_Node, Expr_Node);
Set_Discrete_Range (Name_Node, Range_Node);
T_Right_Paren;
goto Scan_Name_Extension;
else
Append (Expr, Expressions (Name_Node));
exit when not Comma_Present;
end if;
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 in Tok_Arrow | 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 in Tok_Arrow | 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 incorrect substitute)
if Token in Tok_Arrow | 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;
-------------------------------------
-- P_Reduction_Attribute_Reference --
-------------------------------------
function P_Reduction_Attribute_Reference (S : Node_Id)
return Node_Id
is
Attr_Node : Node_Id;
Attr_Name : Name_Id;
begin
Attr_Name := Token_Name;
Scan; -- past Reduce
Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
Set_Attribute_Name (Attr_Node, Attr_Name);
if Attr_Name /= Name_Reduce then
Error_Msg ("Reduce attribute expected", Prev_Token_Ptr);
end if;
Set_Prefix (Attr_Node, S);
Set_Expressions (Attr_Node, New_List);
T_Left_Paren;
Append (P_Name, Expressions (Attr_Node));
T_Comma;
Append (P_Expression, Expressions (Attr_Node));
T_Right_Paren;
return Attr_Node;
end P_Reduction_Attribute_Reference;
---------------------------------------
-- 4.1.4 Range Attribute Designator --
---------------------------------------
-- Parsed by P_Range_Attribute_Reference (4.4)
---------------------------------------------
-- 4.1.4 (2) Reduction_Attribute_Reference --
---------------------------------------------
-- parsed by P_Reduction_Attribute_Reference
--------------------
-- 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
and then Ada_Version < Ada_2022
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.
function Is_Quantified_Expression return Boolean;
-- The presence of iterated component associations requires a one
-- token lookahead to distinguish it from quantified expressions.
---------------
-- Box_Error --
---------------
procedure Box_Error is
begin
Error_Msg_Ada_2005_Extension ("'<'> in aggregate");
-- 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;
------------------------------
-- Is_Quantified_Expression --
------------------------------
function Is_Quantified_Expression return Boolean is
Maybe : Boolean;
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past FOR
Maybe := Token in Tok_All | Tok_Some;
Restore_Scan_State (Scan_State); -- to FOR
return Maybe;
end Is_Quantified_Expression;
Start_Token : constant Token_Type := Token;
-- Used to prevent mismatches (...] and [...)
-- Start of processing for P_Aggregate_Or_Paren_Expr
begin
Lparen_Sloc := Token_Ptr;
if Token = Tok_Left_Bracket then
Scan;
-- Special case for null aggregate in Ada 2022
if Token = Tok_Right_Bracket then
Scan; -- past ]
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
Set_Expressions (Aggregate_Node, New_List);
Set_Component_Associations (Aggregate_Node, New_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
return Aggregate_Node;
end if;
else
T_Left_Paren;
end if;
-- 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 and then Is_Quantified_Expression 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;
elsif Token = Tok_For then
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
Expr_Node := P_Iterated_Component_Association;
goto Aggregate;
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 or Delta 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;
Scan; -- past WITH
if Token = Tok_Delta then
Scan; -- past DELTA
Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
Set_Expression (Aggregate_Node, Expr_Node);
Expr_Node := Empty;
goto Aggregate;
else
Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
Set_Ancestor_Part (Aggregate_Node, Expr_Node);
end if;
-- 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
<<Aggregate>>
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
Append_New (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.
-- In Ada 2012 and 2022 an iterated association can appear.
elsif Nkind (Expr_Node) in
N_Iterated_Component_Association | N_Iterated_Element_Association
then
Append_New (Expr_Node, Assoc_List);
elsif Token in Tok_Comma | Tok_Right_Paren | Tok_Others
| Token_Class_Lit_Or_Name | Tok_Semicolon
then
if Present (Assoc_List) then
Error_Msg_BC -- CODEFIX
("""='>"" expected (positional association cannot follow "
& "named association)");
end if;
Append_New (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;
Append_New (Expr_Node, Expr_List);
elsif Token = Tok_Right_Bracket then
Append_New (Expr_Node, Expr_List);
exit;
-- Anything else is assumed to be a named association
else
Restore_Scan_State (Scan_State); -- to start of expression
Append_New (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 and then Token /= Tok_For 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 or FOR,
-- which indicates an iterated component association.
elsif Token = Tok_Others then
Expr_Node := Empty;
elsif Token = Tok_For then
Expr_Node := P_Iterated_Component_Association;
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.
-- Scan ] or ) based on Start_Token.
case Start_Token is
when Tok_Left_Bracket =>
Set_Component_Associations (Aggregate_Node, Assoc_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
T_Right_Bracket;
if Token = Tok_Apostrophe then
Scan;
if Token = Tok_Identifier then
return P_Reduction_Attribute_Reference (Aggregate_Node);
end if;
end if;
when Tok_Left_Paren =>
if Nkind (Aggregate_Node) = N_Aggregate then
Set_Is_Parenthesis_Aggregate (Aggregate_Node);
end if;
T_Right_Paren;
when others => raise Program_Error;
end case;
if Nkind (Aggregate_Node) /= N_Delta_Aggregate then
Set_Expressions (Aggregate_Node, Expr_List);
end if;
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 => <>
-- | ITERATED_COMPONENT_ASSOCIATION
-- 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;
Box_Present : Boolean := False;
Box_With_Identifier_Present : Boolean := False;
begin
-- A loop indicates an iterated_component_association
if Token = Tok_For then
return P_Iterated_Component_Association;
end if;
Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
Set_Binding_Chars (Assoc_Node, No_Name);
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
Error_Msg_Ada_2005_Extension ("component association with '<'>");
Box_Present := True;
Set_Box_Present (Assoc_Node);
Scan; -- past box
elsif Token = Tok_Less then
declare
Scan_State : Saved_Scan_State;
Id : Node_Id;
begin
Save_Scan_State (Scan_State);
Scan; -- past "<"
if Token = Tok_Identifier then
Id := P_Defining_Identifier;
if Token = Tok_Greater then
if Core_Extensions_Allowed then
Set_Box_Present (Assoc_Node);
Set_Binding_Chars (Assoc_Node, Chars (Id));
Box_Present := True;
Box_With_Identifier_Present := True;
Scan; -- past ">"
else
Error_Msg_GNAT_Extension
("identifier within box", Token_Ptr);
Box_Present := True;
-- Avoid cascading errors by ignoring the identifier
end if;
end if;
end if;
if not Box_Present then
-- it wasn't an "is <identifier>", so restore.
Restore_Scan_State (Scan_State);
end if;
end;
end if;
if not Box_Present then
Set_Expression (Assoc_Node, P_Expression);
end if;
-- Check for "is <identifier>" for aggregate that is part of
-- a pattern for a general case statement.
if Token = Tok_Is then
declare
Scan_State : Saved_Scan_State;
Id : Node_Id;
begin
Save_Scan_State (Scan_State);
Scan; -- past "is"
if Token = Tok_Identifier then
Id := P_Defining_Identifier;
if not Core_Extensions_Allowed then
Error_Msg_GNAT_Extension
("IS following component association", Token_Ptr);
elsif Box_With_Identifier_Present then
Error_Msg
("Both identifier-in-box and trailing identifier"
& " specified for one component association",
Token_Ptr);
else
Set_Binding_Chars (Assoc_Node, Chars (Id));
end if;
else
-- It wasn't an "is <identifier>", so restore.
Restore_Scan_State (Scan_State);
end if;
end;
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);
-- Check for case of errant comma or semicolon
if Token in Tok_Comma | Tok_Semicolon then
declare
Com : constant Boolean := Token = Tok_Comma;
Scan_State : Saved_Scan_State;
Logop : Node_Kind;
begin
Save_Scan_State (Scan_State); -- at comma/semicolon
Scan; -- past comma/semicolon
-- Check for AND THEN or OR ELSE after comma/semicolon. We
-- do not deal with AND/OR because those cases get mixed up
-- with the select alternatives case.
if Token in Tok_And | Tok_Or then
Logop := P_Logical_Operator;
Restore_Scan_State (Scan_State); -- to comma/semicolon
if Logop in N_And_Then | N_Or_Else then
Scan; -- past comma/semicolon
if Com then
Error_Msg_SP -- CODEFIX
("|extra "","" ignored");
else
Error_Msg_SP -- CODEFIX
("|extra "";"" ignored");
end if;
else
Restore_Scan_State (Scan_State); -- to comma/semicolon
end if;
else
Restore_Scan_State (Scan_State); -- to comma/semicolon
end if;
end;
end if;
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 in Tok_Case | Tok_If | Tok_For | Tok_Declare then
return P_Unparen_Cond_Expr_Etc;
-- 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: cannot 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 in Tok_Case | Tok_If | Tok_For | Tok_Declare then
return P_Unparen_Cond_Expr_Etc;
-- 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
-- | RAISE_EXPRESSION
-- MEMBERSHIP_CHOICE_LIST ::=
-- MEMBERSHIP_CHOICE {'|' MEMBERSHIP CHOICE}
-- MEMBERSHIP_CHOICE ::=
-- CHOICE_EXPRESSION | RANGE | SUBTYPE_MARK
-- RAISE_EXPRESSION ::= raise exception_NAME [with string_EXPRESSION]
-- 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
-- First check for raise expression
if Token = Tok_Raise then
Expr_Form := EF_Non_Simple;
return P_Raise_Expression;
end if;
-- All other cases
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;
function At_Start_Of_Attribute return Boolean;
-- Tests if we have quote followed by attribute name, if so, return True
-- otherwise return False.
---------------------------
-- At_Start_Of_Attribute --
---------------------------
function At_Start_Of_Attribute return Boolean is
begin
if Token /= Tok_Apostrophe then
return False;
else
declare
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State);
Scan; -- past quote
if Token = Tok_Identifier
and then Is_Attribute_Name (Chars (Token_Node))
then
Restore_Scan_State (Scan_State);
return True;
else
Restore_Scan_State (Scan_State);
return False;
end if;
end;
end if;
end At_Start_Of_Attribute;
-- Start of processing for P_Simple_Expression
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 (Inside_Depends);
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);
if Style_Check and then not Debug_Flag_Dot_QQ then
Style.Check_Binary_Operator;
end if;
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
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.
New_Node :=
Make_Op_Concat (Loc,
Make_String_Literal (Loc, Null_String_Id),
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;
-- And if we have a quote, we may have a bad attribute
elsif At_Start_Of_Attribute then
Error_Msg_SC ("prefix of attribute must be a name");
if Ada_Version >= Ada_2012 then
Error_Msg_SC ("\qualify expression to turn it into a name");
end if;
-- Normal case for binary operator expected message
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);
if Style_Check and then not Debug_Flag_Dot_QQ 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;
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
-- | REDUCTION_ATTRIBUTE_REFERENCE
-- 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_Identifier
| Tok_Operator_Symbol
=>
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;
when Tok_Left_Bracket =>
return P_Aggregate;
-- 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
or else
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
Save_Scan_State (Scan_State);
Scan; -- past FOR
if Token in Tok_All | Tok_Some then
Restore_Scan_State (Scan_State); -- To FOR
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;
else
Restore_Scan_State (Scan_State); -- To FOR
Node1 := P_Iterated_Component_Association;
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
when Tok_At_Sign => -- AI12-0125 : target_name
Error_Msg_Ada_2022_Feature ("target name", Token_Ptr);
Node1 := P_Name;
return Node1;
-- 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
Error_Msg_Ada_2012_Feature ("quantified expression", Token_Ptr);
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 ALL or 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;
Error_Msg_Ada_2012_Feature
("|subpool specification",
Sloc (Subpool_Handle_Name (Alloc_Node)));
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
Error_Msg_Ada_2012_Feature ("|case expression", Token_Ptr);
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;
-- A semicolon followed by "when" is probably meant to be a comma
elsif Token = Tok_Semicolon then
Save_Scan_State (Save_State);
Scan; -- past the semicolon
if Token /= Tok_When then
Restore_Scan_State (Save_State);
exit;
end if;
Error_Msg_SP -- CODEFIX
("|"";"" should be "",""");
-- 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_Iterated_Component_Association --
--------------------------------------
-- ITERATED_COMPONENT_ASSOCIATION ::=
-- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION
-- for ITERATOR_SPECIFICATION => EXPRESSION
function P_Iterated_Component_Association return Node_Id is
Assoc_Node : Node_Id;
Choice : Node_Id;
Filter : Node_Id := Empty;
Id : Node_Id;
Iter_Spec : Node_Id;
Loop_Spec : Node_Id;
State : Saved_Scan_State;
procedure Build_Iterated_Element_Association;
-- If the iterator includes a key expression or a filter, it is
-- an Ada 2022 Iterator_Element_Association within a container
-- aggregate.
----------------------------------------
-- Build_Iterated_Element_Association --
----------------------------------------
procedure Build_Iterated_Element_Association is
begin
-- Build loop_parameter_specification
Loop_Spec :=
New_Node (N_Loop_Parameter_Specification, Prev_Token_Ptr);
Set_Defining_Identifier (Loop_Spec, Id);
Choice := First (Discrete_Choices (Assoc_Node));
Assoc_Node :=
New_Node (N_Iterated_Element_Association, Prev_Token_Ptr);
Set_Loop_Parameter_Specification (Assoc_Node, Loop_Spec);
if Present (Next (Choice)) then
Error_Msg_N ("expect loop parameter specification", Choice);
end if;
Remove (Choice);
Set_Discrete_Subtype_Definition (Loop_Spec, Choice);
Set_Iterator_Filter (Loop_Spec, Filter);
end Build_Iterated_Element_Association;
-- Start of processing for P_Iterated_Component_Association
begin
Scan; -- past FOR
Save_Scan_State (State);
-- A lookahead is necessary to differentiate between the
-- Ada 2012 form with a choice list, and the Ada 2022 element
-- iterator form, recognized by the presence of "OF". Other
-- disambiguation requires context and is done during semantic
-- analysis. Note that "for X in E" is syntactically ambiguous:
-- if E is a subtype indication this is a loop parameter spec,
-- while if E a name it is an iterator_specification, and the
-- disambiguation takes place during semantic analysis.
-- In addition, if "use" is present after the specification,
-- this is an Iterated_Element_Association that carries a
-- key_expression, and we generate the appropriate node.
-- Finally, the Iterated_Element form is reserved for container
-- aggregates, and is illegal in array aggregates.
Id := P_Defining_Identifier;
Assoc_Node :=
New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);
case Token is
when Tok_In =>
Set_Defining_Identifier (Assoc_Node, Id);
T_In;
Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
-- The iterator may include a filter
if Token = Tok_When then
Scan; -- past WHEN
Filter := P_Condition;
end if;
if Token = Tok_Use then
-- Ada 2022 Key-expression is present, rewrite node as an
-- Iterated_Element_Association.
Scan; -- past USE
Build_Iterated_Element_Association;
Set_Key_Expression (Assoc_Node, P_Expression);
elsif Present (Filter) then
-- A loop_parameter_specification also indicates an Ada 2022
-- construct, in contrast with a subtype indication used in
-- array aggregates.
Build_Iterated_Element_Association;
end if;
TF_Arrow;
Set_Expression (Assoc_Node, P_Expression);
when Tok_Of =>
Restore_Scan_State (State);
Scan; -- past OF
Iter_Spec := P_Iterator_Specification (Id);
Set_Iterator_Specification (Assoc_Node, Iter_Spec);
if Token = Tok_Use then
Scan; -- past USE
-- This is an iterated_element_association
Assoc_Node :=
New_Node (N_Iterated_Element_Association, Prev_Token_Ptr);
Set_Iterator_Specification (Assoc_Node, Iter_Spec);
Set_Key_Expression (Assoc_Node, P_Expression);
end if;
TF_Arrow;
Set_Expression (Assoc_Node, P_Expression);
when others =>
Error_Msg_AP ("missing IN or OF");
end case;
return Assoc_Node;
end P_Iterated_Component_Association;
---------------------
-- P_If_Expression --
---------------------
-- IF_EXPRESSION ::=
-- if CONDITION then DEPENDENT_EXPRESSION
-- {elsif CONDITION then DEPENDENT_EXPRESSION}
-- [else DEPENDENT_EXPRESSION]
-- DEPENDENT_EXPRESSION ::= EXPRESSION
function P_If_Expression return Node_Id is
function P_If_Expression_Internal
(Loc : Source_Ptr;
Cond : Node_Id) return Node_Id;
-- This is the internal recursive routine that does all the work, it is
-- recursive since it is used to process ELSIF parts, which internally
-- are N_If_Expression nodes with the Is_Elsif flag set. The calling
-- sequence is like the outer function except that the caller passes
-- the conditional expression (scanned using P_Expression), and the
-- scan pointer points just past this expression. Loc points to the
-- IF or ELSIF token.
------------------------------
-- P_If_Expression_Internal --
------------------------------
function P_If_Expression_Internal
(Loc : Source_Ptr;
Cond : Node_Id) return Node_Id
is
Exprs : constant List_Id := New_List;
Expr : Node_Id;
State : Saved_Scan_State;
Eptr : Source_Ptr;
begin
-- All cases except where we are at right paren
if Token /= Tok_Right_Paren then
TF_Then;
Append_To (Exprs, P_Condition (Cond));
Append_To (Exprs, P_Expression);
-- Case of right paren (missing THEN phrase). Note that we know this
-- is the IF case, since the caller dealt with this possibility in
-- the ELSIF case.
else
Error_Msg_BC ("missing THEN phrase");
Append_To (Exprs, P_Condition (Cond));
end if;
-- 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 in Tok_Else | 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
Eptr := Token_Ptr;
Scan; -- past ELSIF
Expr := P_Expression;
-- If we are at a right paren, we assume the ELSIF should be ELSE
if Token = Tok_Right_Paren then
Error_Msg ("ELSIF should be ELSE", Eptr);
Append_To (Exprs, Expr);
-- Otherwise we have an OK ELSIF
else
Expr := P_If_Expression_Internal (Eptr, Expr);
Set_Is_Elsif (Expr);
Append_To (Exprs, Expr);
end if;
-- Scan out ELSE phrase if present
elsif Token = Tok_Else then
-- Scan out ELSE expression
Scan; -- Past ELSE
Append_To (Exprs, P_Expression);
-- Skip redundant ELSE parts
while Token = Tok_Else loop
Error_Msg_SC ("only one ELSE part is allowed");
Scan; -- past ELSE
Discard_Junk_Node (P_Expression);
end loop;
-- 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;
-- Return the If_Expression node
return Make_If_Expression (Loc, Expressions => Exprs);
end P_If_Expression_Internal;
-- Local variables
Loc : constant Source_Ptr := Token_Ptr;
If_Expr : Node_Id;
-- Start of processing for P_If_Expression
begin
Error_Msg_Ada_2012_Feature ("|if expression", Token_Ptr);
Scan; -- past IF
Inside_If_Expression := Inside_If_Expression + 1;
If_Expr := P_If_Expression_Internal (Loc, P_Expression);
Inside_If_Expression := Inside_If_Expression - 1;
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 DECLARE
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
Error_Msg_Ada_2022_Feature ("declare expression", Loc);
return Result;
end;
end;
end P_Declare_Expression;
-----------------------
-- P_Membership_Test --
-----------------------
-- MEMBERSHIP_CHOICE_LIST ::= MEMBERSHIP_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
Error_Msg_Ada_2012_Feature ("set notation", Token_Ptr);
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_Expr_Etc --
-----------------------------
function P_Unparen_Cond_Expr_Etc return Node_Id is
Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
Result : Node_Id;
Scan_State : Saved_Scan_State;
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 or iterated component association
elsif Token = Tok_For then
Save_Scan_State (Scan_State);
Scan; -- past FOR
if Token in Tok_All | Tok_Some then
Restore_Scan_State (Scan_State);
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;
else
-- If no quantifier keyword, this is an iterated component in
-- an aggregate.
Restore_Scan_State (Scan_State);
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
raise Program_Error;
end if;
-- Return expression (possibly after having given message)
return Result;
end P_Unparen_Cond_Expr_Etc;
end Ch4;