3401 lines
112 KiB
Ada
3401 lines
112 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- P A R . C H 4 --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2015, 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)). The Ada2012 attribute 'Old is in
|
|
-- this category.
|
|
|
|
-- 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_Record_Or_Array_Component_Association return Node_Id;
|
|
function P_Factor return Node_Id;
|
|
function P_Primary return Node_Id;
|
|
function P_Relation return Node_Id;
|
|
function P_Term return Node_Id;
|
|
|
|
function P_Binary_Adding_Operator return Node_Kind;
|
|
function P_Logical_Operator return Node_Kind;
|
|
function P_Multiplying_Operator return Node_Kind;
|
|
function P_Relational_Operator return Node_Kind;
|
|
function P_Unary_Adding_Operator return Node_Kind;
|
|
|
|
procedure Bad_Range_Attribute (Loc : Source_Ptr);
|
|
-- Called to place complaint about bad range attribute at the given
|
|
-- source location. Terminates by raising Error_Resync.
|
|
|
|
procedure Check_Bad_Exp;
|
|
-- Called after scanning a**b, posts error if ** detected
|
|
|
|
procedure P_Membership_Test (N : Node_Id);
|
|
-- N is the node for a N_In or N_Not_In node whose right operand has not
|
|
-- yet been processed. It is called just after scanning out the IN keyword.
|
|
-- On return, either Right_Opnd or Alternatives is set, as appropriate.
|
|
|
|
function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id;
|
|
-- Scan a range attribute reference. The caller has scanned out the
|
|
-- prefix. The current token is known to be an apostrophe and the
|
|
-- following token is known to be RANGE.
|
|
|
|
function P_Unparen_Cond_Case_Quant_Expression return Node_Id;
|
|
-- This function is called with Token pointing to IF, CASE, or FOR, in a
|
|
-- context that allows a case, conditional, or quantified expression if
|
|
-- it is surrounded by parentheses. If not surrounded by parentheses, the
|
|
-- expression is still returned, but an error message is issued.
|
|
|
|
-------------------------
|
|
-- Bad_Range_Attribute --
|
|
-------------------------
|
|
|
|
procedure Bad_Range_Attribute (Loc : Source_Ptr) is
|
|
begin
|
|
Error_Msg ("range attribute cannot be used in expression!", Loc);
|
|
Resync_Expression;
|
|
end Bad_Range_Attribute;
|
|
|
|
-------------------
|
|
-- Check_Bad_Exp --
|
|
-------------------
|
|
|
|
procedure Check_Bad_Exp is
|
|
begin
|
|
if Token = Tok_Double_Asterisk then
|
|
Error_Msg_SC ("parenthesization required for '*'*");
|
|
Scan; -- past **
|
|
Discard_Junk_Node (P_Primary);
|
|
Check_Bad_Exp;
|
|
end if;
|
|
end Check_Bad_Exp;
|
|
|
|
--------------------------
|
|
-- 4.1 Name (also 6.4) --
|
|
--------------------------
|
|
|
|
-- NAME ::=
|
|
-- DIRECT_NAME | EXPLICIT_DEREFERENCE
|
|
-- | INDEXED_COMPONENT | SLICE
|
|
-- | SELECTED_COMPONENT | ATTRIBUTE
|
|
-- | TYPE_CONVERSION | FUNCTION_CALL
|
|
-- | CHARACTER_LITERAL
|
|
|
|
-- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
|
|
|
|
-- PREFIX ::= NAME | IMPLICIT_DEREFERENCE
|
|
|
|
-- EXPLICIT_DEREFERENCE ::= NAME . all
|
|
|
|
-- IMPLICIT_DEREFERENCE ::= NAME
|
|
|
|
-- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION})
|
|
|
|
-- SLICE ::= PREFIX (DISCRETE_RANGE)
|
|
|
|
-- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME
|
|
|
|
-- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL
|
|
|
|
-- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR
|
|
|
|
-- ATTRIBUTE_DESIGNATOR ::=
|
|
-- IDENTIFIER [(static_EXPRESSION)]
|
|
-- | access | delta | digits
|
|
|
|
-- FUNCTION_CALL ::=
|
|
-- function_NAME
|
|
-- | function_PREFIX ACTUAL_PARAMETER_PART
|
|
|
|
-- ACTUAL_PARAMETER_PART ::=
|
|
-- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION})
|
|
|
|
-- PARAMETER_ASSOCIATION ::=
|
|
-- [formal_parameter_SELECTOR_NAME =>] EXPLICIT_ACTUAL_PARAMETER
|
|
|
|
-- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
|
|
|
|
-- Note: syntactically a procedure call looks just like a function call,
|
|
-- so this routine is in practice used to scan out procedure calls as well.
|
|
|
|
-- On return, Expr_Form is set to either EF_Name or EF_Simple_Name
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
-- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be
|
|
-- followed by either a left paren (qualified expression case), or by
|
|
-- range (range attribute case). All other uses of apostrophe (i.e. all
|
|
-- other attributes) are handled in this routine.
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
function P_Name return Node_Id is
|
|
Scan_State : Saved_Scan_State;
|
|
Name_Node : Node_Id;
|
|
Prefix_Node : Node_Id;
|
|
Ident_Node : Node_Id;
|
|
Expr_Node : Node_Id;
|
|
Range_Node : Node_Id;
|
|
Arg_Node : Node_Id;
|
|
|
|
Arg_List : List_Id := No_List; -- kill junk warning
|
|
Attr_Name : Name_Id := No_Name; -- kill junk warning
|
|
|
|
begin
|
|
-- Case of not a name
|
|
|
|
if Token not in Token_Class_Name then
|
|
|
|
-- If it looks like start of expression, complain and scan expression
|
|
|
|
if Token in Token_Class_Literal
|
|
or else Token = Tok_Left_Paren
|
|
then
|
|
Error_Msg_SC ("name expected");
|
|
return P_Expression;
|
|
|
|
-- Otherwise some other junk, not much we can do
|
|
|
|
else
|
|
Error_Msg_AP ("name expected");
|
|
raise Error_Resync;
|
|
end if;
|
|
end if;
|
|
|
|
-- Loop through designators in qualified name
|
|
|
|
Name_Node := Token_Node;
|
|
|
|
loop
|
|
Scan; -- past designator
|
|
exit when Token /= Tok_Dot;
|
|
Save_Scan_State (Scan_State); -- at dot
|
|
Scan; -- past dot
|
|
|
|
-- If we do not have another designator after the dot, then join
|
|
-- the normal circuit to handle a dot extension (may be .all or
|
|
-- character literal case). Otherwise loop back to scan the next
|
|
-- designator.
|
|
|
|
if Token not in Token_Class_Desig then
|
|
goto Scan_Name_Extension_Dot;
|
|
else
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Selector_Name (Name_Node, Token_Node);
|
|
end if;
|
|
end loop;
|
|
|
|
-- We have now scanned out a qualified designator. If the last token is
|
|
-- an operator symbol, then we certainly do not have the Snam case, so
|
|
-- we can just use the normal name extension check circuit
|
|
|
|
if Prev_Token = Tok_Operator_Symbol then
|
|
goto Scan_Name_Extension;
|
|
end if;
|
|
|
|
-- We have scanned out a qualified simple name, check for name extension
|
|
-- Note that we know there is no dot here at this stage, so the only
|
|
-- possible cases of name extension are apostrophe and left paren.
|
|
|
|
if Token = Tok_Apostrophe then
|
|
Save_Scan_State (Scan_State); -- at apostrophe
|
|
Scan; -- past apostrophe
|
|
|
|
-- Qualified expression in Ada 2012 mode (treated as a name)
|
|
|
|
if Ada_Version >= Ada_2012 and then Token = Tok_Left_Paren then
|
|
goto Scan_Name_Extension_Apostrophe;
|
|
|
|
-- If left paren not in Ada 2012, then it is not part of the name,
|
|
-- since qualified expressions are not names in prior versions of
|
|
-- Ada, so return with Token backed up to point to the apostrophe.
|
|
-- The treatment for the range attribute is similar (we do not
|
|
-- consider x'range to be a name in this grammar).
|
|
|
|
elsif Token = Tok_Left_Paren or else Token = Tok_Range then
|
|
Restore_Scan_State (Scan_State); -- to apostrophe
|
|
Expr_Form := EF_Simple_Name;
|
|
return Name_Node;
|
|
|
|
-- Otherwise we have the case of a name extended by an attribute
|
|
|
|
else
|
|
goto Scan_Name_Extension_Apostrophe;
|
|
end if;
|
|
|
|
-- Check case of qualified simple name extended by a left parenthesis
|
|
|
|
elsif Token = Tok_Left_Paren then
|
|
Scan; -- past left paren
|
|
goto Scan_Name_Extension_Left_Paren;
|
|
|
|
-- Otherwise the qualified simple name is not extended, so return
|
|
|
|
else
|
|
Expr_Form := EF_Simple_Name;
|
|
return Name_Node;
|
|
end if;
|
|
|
|
-- Loop scanning past name extensions. A label is used for control
|
|
-- transfer for this loop for ease of interfacing with the finite state
|
|
-- machine in the parenthesis scanning circuit, and also to allow for
|
|
-- passing in control to the appropriate point from the above code.
|
|
|
|
<<Scan_Name_Extension>>
|
|
|
|
-- Character literal used as name cannot be extended. Also this
|
|
-- cannot be a call, since the name for a call must be a designator.
|
|
-- Return in these cases, or if there is no name extension
|
|
|
|
if Token not in Token_Class_Namext
|
|
or else Prev_Token = Tok_Char_Literal
|
|
then
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
end if;
|
|
|
|
-- Merge here when we know there is a name extension
|
|
|
|
<<Scan_Name_Extension_OK>>
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan; -- past left paren
|
|
goto Scan_Name_Extension_Left_Paren;
|
|
|
|
elsif Token = Tok_Apostrophe then
|
|
Save_Scan_State (Scan_State); -- at apostrophe
|
|
Scan; -- past apostrophe
|
|
goto Scan_Name_Extension_Apostrophe;
|
|
|
|
else -- Token = Tok_Dot
|
|
Save_Scan_State (Scan_State); -- at dot
|
|
Scan; -- past dot
|
|
goto Scan_Name_Extension_Dot;
|
|
end if;
|
|
|
|
-- Case of name extended by dot (selection), dot is already skipped
|
|
-- and the scan state at the point of the dot is saved in Scan_State.
|
|
|
|
<<Scan_Name_Extension_Dot>>
|
|
|
|
-- Explicit dereference case
|
|
|
|
if Token = Tok_All then
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr);
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Scan; -- past ALL
|
|
goto Scan_Name_Extension;
|
|
|
|
-- Selected component case
|
|
|
|
elsif Token in Token_Class_Name then
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Selector_Name (Name_Node, Token_Node);
|
|
Scan; -- past selector
|
|
goto Scan_Name_Extension;
|
|
|
|
-- Reserved identifier as selector
|
|
|
|
elsif Is_Reserved_Identifier then
|
|
Scan_Reserved_Identifier (Force_Msg => False);
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Selector_Name (Name_Node, Token_Node);
|
|
Scan; -- past identifier used as selector
|
|
goto Scan_Name_Extension;
|
|
|
|
-- If dot is at end of line and followed by nothing legal,
|
|
-- then assume end of name and quit (dot will be taken as
|
|
-- an 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 = Tok_Left_Paren then
|
|
Name_Node := P_Qualified_Expression (Name_Node);
|
|
goto Scan_Name_Extension;
|
|
|
|
-- If range attribute after apostrophe, then return with Token
|
|
-- pointing to the apostrophe. Note that in this case the prefix
|
|
-- need not be a simple name (cases like A.all'range). Similarly
|
|
-- if there is a left paren after the apostrophe, then we also
|
|
-- return with Token pointing to the apostrophe (this is the
|
|
-- aggregate case, or some error case).
|
|
|
|
elsif Token = Tok_Range or else Token = Tok_Left_Paren then
|
|
Restore_Scan_State (Scan_State); -- to apostrophe
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
|
|
-- Here for cases where attribute designator is an identifier
|
|
|
|
elsif Token = Tok_Identifier then
|
|
Attr_Name := Token_Name;
|
|
|
|
if not Is_Attribute_Name (Attr_Name) then
|
|
if Apostrophe_Should_Be_Semicolon then
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
|
|
-- Here for a bad attribute name
|
|
|
|
else
|
|
Signal_Bad_Attribute;
|
|
Scan; -- past bad identifier
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan; -- past left paren
|
|
|
|
loop
|
|
Discard_Junk_Node (P_Expression_If_OK);
|
|
exit when not Comma_Present;
|
|
end loop;
|
|
|
|
T_Right_Paren;
|
|
end if;
|
|
|
|
return Error;
|
|
end if;
|
|
end if;
|
|
|
|
if Style_Check then
|
|
Style.Check_Attribute_Name (False);
|
|
end if;
|
|
|
|
-- Here for case of attribute designator is not an identifier
|
|
|
|
else
|
|
if Token = Tok_Delta then
|
|
Attr_Name := Name_Delta;
|
|
|
|
elsif Token = Tok_Digits then
|
|
Attr_Name := Name_Digits;
|
|
|
|
elsif Token = Tok_Access then
|
|
Attr_Name := Name_Access;
|
|
|
|
elsif Token = Tok_Mod and then Ada_Version >= Ada_95 then
|
|
Attr_Name := Name_Mod;
|
|
|
|
elsif Apostrophe_Should_Be_Semicolon then
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
|
|
else
|
|
Error_Msg_AP ("attribute designator expected");
|
|
raise Error_Resync;
|
|
end if;
|
|
|
|
if Style_Check then
|
|
Style.Check_Attribute_Name (True);
|
|
end if;
|
|
end if;
|
|
|
|
-- We come here with an OK attribute scanned, and corresponding
|
|
-- Attribute identifier node stored in Ident_Node.
|
|
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr);
|
|
Scan; -- past attribute designator
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Attribute_Name (Name_Node, Attr_Name);
|
|
|
|
-- Scan attribute arguments/designator. We skip this if we know
|
|
-- that the attribute cannot have an argument (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
|
|
Append (Expr, Expressions (Name_Node));
|
|
exit when not Comma_Present;
|
|
end if;
|
|
end;
|
|
end loop;
|
|
|
|
T_Right_Paren;
|
|
end if;
|
|
end if;
|
|
|
|
goto Scan_Name_Extension;
|
|
end Scan_Apostrophe;
|
|
|
|
-- Here for left parenthesis extending name (left paren skipped)
|
|
|
|
<<Scan_Name_Extension_Left_Paren>>
|
|
|
|
-- We now have to scan through a list of items, terminated by a
|
|
-- right parenthesis. The scan is handled by a finite state
|
|
-- machine. The possibilities are:
|
|
|
|
-- (discrete_range)
|
|
|
|
-- This is a slice. This case is handled in LP_State_Init
|
|
|
|
-- (expression, expression, ..)
|
|
|
|
-- This is interpreted as an indexed component, i.e. as a
|
|
-- case of a name which can be extended in the normal manner.
|
|
-- This case is handled by LP_State_Name or LP_State_Expr.
|
|
|
|
-- Note: if and case expressions (without an extra level of
|
|
-- parentheses) are permitted in this context).
|
|
|
|
-- (..., identifier => expression , ...)
|
|
|
|
-- If there is at least one occurrence of identifier => (but
|
|
-- none of the other cases apply), then we have a call.
|
|
|
|
-- Test for Id => case
|
|
|
|
if Token = Tok_Identifier then
|
|
Save_Scan_State (Scan_State); -- at Id
|
|
Scan; -- past Id
|
|
|
|
-- Test for => (allow := as an error substitute)
|
|
|
|
if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
|
|
Restore_Scan_State (Scan_State); -- to Id
|
|
Arg_List := New_List;
|
|
goto LP_State_Call;
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to Id
|
|
end if;
|
|
end if;
|
|
|
|
-- Here we have an expression after all
|
|
|
|
Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
|
|
|
|
-- Check cases of discrete range for a slice
|
|
|
|
-- First possibility: Range_Attribute_Reference
|
|
|
|
if Expr_Form = EF_Range_Attr then
|
|
Range_Node := Expr_Node;
|
|
|
|
-- Second possibility: Simple_expression .. Simple_expression
|
|
|
|
elsif Token = Tok_Dot_Dot then
|
|
Check_Simple_Expression (Expr_Node);
|
|
Range_Node := New_Node (N_Range, Token_Ptr);
|
|
Set_Low_Bound (Range_Node, Expr_Node);
|
|
Scan; -- past ..
|
|
Expr_Node := P_Expression;
|
|
Check_Simple_Expression (Expr_Node);
|
|
Set_High_Bound (Range_Node, Expr_Node);
|
|
|
|
-- Third possibility: Type_name range Range
|
|
|
|
elsif Token = Tok_Range then
|
|
if Expr_Form /= EF_Simple_Name then
|
|
Error_Msg_SC ("subtype mark must precede RANGE");
|
|
raise Error_Resync;
|
|
end if;
|
|
|
|
Range_Node := P_Subtype_Indication (Expr_Node);
|
|
|
|
-- Otherwise we just have an expression. It is true that we might
|
|
-- have a subtype mark without a range constraint but this case
|
|
-- is syntactically indistinguishable from the expression case.
|
|
|
|
else
|
|
Arg_List := New_List;
|
|
goto LP_State_Expr;
|
|
end if;
|
|
|
|
-- Fall through here with unmistakable Discrete range scanned,
|
|
-- which means that we definitely have the case of a slice. The
|
|
-- Discrete range is in Range_Node.
|
|
|
|
if Token = Tok_Comma then
|
|
Error_Msg_SC ("slice cannot have more than one dimension");
|
|
raise Error_Resync;
|
|
|
|
elsif Token /= Tok_Right_Paren then
|
|
if Token = Tok_Arrow then
|
|
|
|
-- This may be an aggregate that is missing a qualification
|
|
|
|
Error_Msg_SC
|
|
("context of aggregate must be a qualified expression");
|
|
raise Error_Resync;
|
|
|
|
else
|
|
T_Right_Paren;
|
|
raise Error_Resync;
|
|
end if;
|
|
|
|
else
|
|
Scan; -- past right paren
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Slice, Sloc (Prefix_Node));
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Discrete_Range (Name_Node, Range_Node);
|
|
|
|
-- An operator node is legal as a prefix to other names,
|
|
-- but not for a slice.
|
|
|
|
if Nkind (Prefix_Node) = N_Operator_Symbol then
|
|
Error_Msg_N ("illegal prefix for slice", Prefix_Node);
|
|
end if;
|
|
|
|
-- If we have a name extension, go scan it
|
|
|
|
if Token in Token_Class_Namext then
|
|
goto Scan_Name_Extension_OK;
|
|
|
|
-- Otherwise return (a slice is a name, but is not a call)
|
|
|
|
else
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
end if;
|
|
end if;
|
|
|
|
-- In LP_State_Expr, we have scanned one or more expressions, and
|
|
-- so we have a call or an indexed component which is a name. On
|
|
-- entry we have the expression just scanned in Expr_Node and
|
|
-- Arg_List contains the list of expressions encountered so far
|
|
|
|
<<LP_State_Expr>>
|
|
Append (Expr_Node, Arg_List);
|
|
|
|
if Token = Tok_Arrow then
|
|
Error_Msg
|
|
("expect identifier in parameter association", Sloc (Expr_Node));
|
|
Scan; -- past arrow
|
|
|
|
elsif not Comma_Present then
|
|
T_Right_Paren;
|
|
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node));
|
|
Set_Prefix (Name_Node, Prefix_Node);
|
|
Set_Expressions (Name_Node, Arg_List);
|
|
|
|
goto Scan_Name_Extension;
|
|
end if;
|
|
|
|
-- Comma present (and scanned out), test for identifier => case
|
|
-- Test for identifier => case
|
|
|
|
if Token = Tok_Identifier then
|
|
Save_Scan_State (Scan_State); -- at Id
|
|
Scan; -- past Id
|
|
|
|
-- Test for => (allow := as error substitute)
|
|
|
|
if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
|
|
Restore_Scan_State (Scan_State); -- to Id
|
|
goto LP_State_Call;
|
|
|
|
-- Otherwise it's just an expression after all, so backup
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to Id
|
|
end if;
|
|
end if;
|
|
|
|
-- Here we have an expression after all, so stay in this state
|
|
|
|
Expr_Node := P_Expression_If_OK;
|
|
goto LP_State_Expr;
|
|
|
|
-- LP_State_Call corresponds to the situation in which at least one
|
|
-- instance of Id => Expression has been encountered, so we know that
|
|
-- we do not have a name, but rather a call. We enter it with the
|
|
-- scan pointer pointing to the next argument to scan, and Arg_List
|
|
-- containing the list of arguments scanned so far.
|
|
|
|
<<LP_State_Call>>
|
|
|
|
-- Test for case of Id => Expression (named parameter)
|
|
|
|
if Token = Tok_Identifier then
|
|
Save_Scan_State (Scan_State); -- at Id
|
|
Ident_Node := Token_Node;
|
|
Scan; -- past Id
|
|
|
|
-- Deal with => (allow := as incorrect substitute)
|
|
|
|
if Token = Tok_Arrow or else Token = Tok_Colon_Equal then
|
|
Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr);
|
|
Set_Selector_Name (Arg_Node, Ident_Node);
|
|
T_Arrow;
|
|
Set_Explicit_Actual_Parameter (Arg_Node, P_Expression);
|
|
Append (Arg_Node, Arg_List);
|
|
|
|
-- If a comma follows, go back and scan next entry
|
|
|
|
if Comma_Present then
|
|
goto LP_State_Call;
|
|
|
|
-- Otherwise we have the end of a call
|
|
|
|
else
|
|
Prefix_Node := Name_Node;
|
|
Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node));
|
|
Set_Name (Name_Node, Prefix_Node);
|
|
Set_Parameter_Associations (Name_Node, Arg_List);
|
|
T_Right_Paren;
|
|
|
|
if Token in Token_Class_Namext then
|
|
goto Scan_Name_Extension_OK;
|
|
|
|
-- This is a case of a call which cannot be a name
|
|
|
|
else
|
|
Expr_Form := EF_Name;
|
|
return Name_Node;
|
|
end if;
|
|
end if;
|
|
|
|
-- Not named parameter: Id started an expression after all
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to Id
|
|
end if;
|
|
end if;
|
|
|
|
-- Here if entry did not start with Id => which means that it
|
|
-- is a positional parameter, which is not allowed, since we
|
|
-- have seen at least one named parameter already.
|
|
|
|
Error_Msg_SC
|
|
("positional parameter association " &
|
|
"not allowed after named one");
|
|
|
|
Expr_Node := P_Expression_If_OK;
|
|
|
|
-- Leaving the '>' in an association is not unusual, so suggest
|
|
-- a possible fix.
|
|
|
|
if Nkind (Expr_Node) = N_Op_Eq then
|
|
Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
|
|
end if;
|
|
|
|
-- We go back to scanning out expressions, so that we do not get
|
|
-- multiple error messages when several positional parameters
|
|
-- follow a named parameter.
|
|
|
|
goto LP_State_Expr;
|
|
|
|
-- End of treatment for name extensions starting with left paren
|
|
|
|
-- End of loop through name extensions
|
|
|
|
end P_Name;
|
|
|
|
-- This function parses a restricted form of Names which are either
|
|
-- designators, or designators preceded by a sequence of prefixes
|
|
-- that are direct names.
|
|
|
|
-- Error recovery: cannot raise Error_Resync
|
|
|
|
function P_Function_Name return Node_Id is
|
|
Designator_Node : Node_Id;
|
|
Prefix_Node : Node_Id;
|
|
Selector_Node : Node_Id;
|
|
Dot_Sloc : Source_Ptr := No_Location;
|
|
|
|
begin
|
|
-- Prefix_Node is set to the gathered prefix so far, Empty means that
|
|
-- no prefix has been scanned. This allows us to build up the result
|
|
-- in the required right recursive manner.
|
|
|
|
Prefix_Node := Empty;
|
|
|
|
-- Loop through prefixes
|
|
|
|
loop
|
|
Designator_Node := Token_Node;
|
|
|
|
if Token not in Token_Class_Desig then
|
|
return P_Identifier; -- let P_Identifier issue the error message
|
|
|
|
else -- Token in Token_Class_Desig
|
|
Scan; -- past designator
|
|
exit when Token /= Tok_Dot;
|
|
end if;
|
|
|
|
-- Here at a dot, with token just before it in Designator_Node
|
|
|
|
if No (Prefix_Node) then
|
|
Prefix_Node := Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
Prefix_Node := Selector_Node;
|
|
end if;
|
|
|
|
Dot_Sloc := Token_Ptr;
|
|
Scan; -- past dot
|
|
end loop;
|
|
|
|
-- Fall out of the loop having just scanned a designator
|
|
|
|
if No (Prefix_Node) then
|
|
return Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
return Selector_Node;
|
|
end if;
|
|
|
|
exception
|
|
when Error_Resync =>
|
|
return Error;
|
|
end P_Function_Name;
|
|
|
|
-- This function parses a restricted form of Names which are either
|
|
-- identifiers, or identifiers preceded by a sequence of prefixes
|
|
-- that are direct names.
|
|
|
|
-- Error recovery: cannot raise Error_Resync
|
|
|
|
function P_Qualified_Simple_Name return Node_Id is
|
|
Designator_Node : Node_Id;
|
|
Prefix_Node : Node_Id;
|
|
Selector_Node : Node_Id;
|
|
Dot_Sloc : Source_Ptr := No_Location;
|
|
|
|
begin
|
|
-- Prefix node is set to the gathered prefix so far, Empty means that
|
|
-- no prefix has been scanned. This allows us to build up the result
|
|
-- in the required right recursive manner.
|
|
|
|
Prefix_Node := Empty;
|
|
|
|
-- Loop through prefixes
|
|
|
|
loop
|
|
Designator_Node := Token_Node;
|
|
|
|
if Token = Tok_Identifier then
|
|
Scan; -- past identifier
|
|
exit when Token /= Tok_Dot;
|
|
|
|
elsif Token not in Token_Class_Desig then
|
|
return P_Identifier; -- let P_Identifier issue the error message
|
|
|
|
else
|
|
Scan; -- past designator
|
|
|
|
if Token /= Tok_Dot then
|
|
Error_Msg_SP ("identifier expected");
|
|
return Error;
|
|
end if;
|
|
end if;
|
|
|
|
-- Here at a dot, with token just before it in Designator_Node
|
|
|
|
if No (Prefix_Node) then
|
|
Prefix_Node := Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
Prefix_Node := Selector_Node;
|
|
end if;
|
|
|
|
Dot_Sloc := Token_Ptr;
|
|
Scan; -- past dot
|
|
end loop;
|
|
|
|
-- Fall out of the loop having just scanned an identifier
|
|
|
|
if No (Prefix_Node) then
|
|
return Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
return Selector_Node;
|
|
end if;
|
|
|
|
exception
|
|
when Error_Resync =>
|
|
return Error;
|
|
end P_Qualified_Simple_Name;
|
|
|
|
-- This procedure differs from P_Qualified_Simple_Name only in that it
|
|
-- raises Error_Resync if any error is encountered. It only returns after
|
|
-- scanning a valid qualified simple name.
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
function P_Qualified_Simple_Name_Resync return Node_Id is
|
|
Designator_Node : Node_Id;
|
|
Prefix_Node : Node_Id;
|
|
Selector_Node : Node_Id;
|
|
Dot_Sloc : Source_Ptr := No_Location;
|
|
|
|
begin
|
|
Prefix_Node := Empty;
|
|
|
|
-- Loop through prefixes
|
|
|
|
loop
|
|
Designator_Node := Token_Node;
|
|
|
|
if Token = Tok_Identifier then
|
|
Scan; -- past identifier
|
|
exit when Token /= Tok_Dot;
|
|
|
|
elsif Token not in Token_Class_Desig then
|
|
Discard_Junk_Node (P_Identifier); -- to issue the error message
|
|
raise Error_Resync;
|
|
|
|
else
|
|
Scan; -- past designator
|
|
|
|
if Token /= Tok_Dot then
|
|
Error_Msg_SP ("identifier expected");
|
|
raise Error_Resync;
|
|
end if;
|
|
end if;
|
|
|
|
-- Here at a dot, with token just before it in Designator_Node
|
|
|
|
if No (Prefix_Node) then
|
|
Prefix_Node := Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
Prefix_Node := Selector_Node;
|
|
end if;
|
|
|
|
Dot_Sloc := Token_Ptr;
|
|
Scan; -- past period
|
|
end loop;
|
|
|
|
-- Fall out of the loop having just scanned an identifier
|
|
|
|
if No (Prefix_Node) then
|
|
return Designator_Node;
|
|
else
|
|
Selector_Node := New_Node (N_Selected_Component, Dot_Sloc);
|
|
Set_Prefix (Selector_Node, Prefix_Node);
|
|
Set_Selector_Name (Selector_Node, Designator_Node);
|
|
return Selector_Node;
|
|
end if;
|
|
end P_Qualified_Simple_Name_Resync;
|
|
|
|
----------------------
|
|
-- 4.1 Direct_Name --
|
|
----------------------
|
|
|
|
-- Parsed by P_Name and other functions in section 4.1
|
|
|
|
-----------------
|
|
-- 4.1 Prefix --
|
|
-----------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
-------------------------------
|
|
-- 4.1 Explicit Dereference --
|
|
-------------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
-------------------------------
|
|
-- 4.1 Implicit_Dereference --
|
|
-------------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
----------------------------
|
|
-- 4.1 Indexed Component --
|
|
----------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
----------------
|
|
-- 4.1 Slice --
|
|
----------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
-----------------------------
|
|
-- 4.1 Selected_Component --
|
|
-----------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
------------------------
|
|
-- 4.1 Selector Name --
|
|
------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
------------------------------
|
|
-- 4.1 Attribute Reference --
|
|
------------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
-------------------------------
|
|
-- 4.1 Attribute Designator --
|
|
-------------------------------
|
|
|
|
-- Parsed by P_Name (4.1)
|
|
|
|
--------------------------------------
|
|
-- 4.1.4 Range Attribute Reference --
|
|
--------------------------------------
|
|
|
|
-- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
|
|
|
|
-- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
|
|
|
|
-- In the grammar, a RANGE attribute is simply a name, but its use is
|
|
-- highly restricted, so in the parser, we do not regard it as a name.
|
|
-- Instead, P_Name returns without scanning the 'RANGE part of the
|
|
-- attribute, and the caller uses the following function to construct
|
|
-- a range attribute in places where it is appropriate.
|
|
|
|
-- Note that RANGE here is treated essentially as an identifier,
|
|
-- rather than a reserved word.
|
|
|
|
-- The caller has parsed the prefix, i.e. a name, and Token points to
|
|
-- the apostrophe. The token after the apostrophe is known to be RANGE
|
|
-- at this point. The prefix node becomes the prefix of the attribute.
|
|
|
|
-- Error_Recovery: Cannot raise Error_Resync
|
|
|
|
function P_Range_Attribute_Reference
|
|
(Prefix_Node : Node_Id)
|
|
return Node_Id
|
|
is
|
|
Attr_Node : Node_Id;
|
|
|
|
begin
|
|
Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr);
|
|
Set_Prefix (Attr_Node, Prefix_Node);
|
|
Scan; -- past apostrophe
|
|
|
|
if Style_Check then
|
|
Style.Check_Attribute_Name (True);
|
|
end if;
|
|
|
|
Set_Attribute_Name (Attr_Node, Name_Range);
|
|
Scan; -- past RANGE
|
|
|
|
if Token = Tok_Left_Paren then
|
|
Scan; -- past left paren
|
|
Set_Expressions (Attr_Node, New_List (P_Expression_If_OK));
|
|
T_Right_Paren;
|
|
end if;
|
|
|
|
return Attr_Node;
|
|
end P_Range_Attribute_Reference;
|
|
|
|
---------------------------------------
|
|
-- 4.1.4 Range Attribute Designator --
|
|
---------------------------------------
|
|
|
|
-- Parsed by P_Range_Attribute_Reference (4.4)
|
|
|
|
--------------------
|
|
-- 4.3 Aggregate --
|
|
--------------------
|
|
|
|
-- AGGREGATE ::= RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where
|
|
-- an aggregate is known to be required (code statement, extension
|
|
-- aggregate), in which cases this routine performs the necessary check
|
|
-- that we have an aggregate rather than a parenthesized expression
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
function P_Aggregate return Node_Id is
|
|
Aggr_Sloc : constant Source_Ptr := Token_Ptr;
|
|
Aggr_Node : constant Node_Id := P_Aggregate_Or_Paren_Expr;
|
|
|
|
begin
|
|
if Nkind (Aggr_Node) /= N_Aggregate
|
|
and then
|
|
Nkind (Aggr_Node) /= N_Extension_Aggregate
|
|
then
|
|
Error_Msg
|
|
("aggregate may not have single positional component", Aggr_Sloc);
|
|
return Error;
|
|
else
|
|
return Aggr_Node;
|
|
end if;
|
|
end P_Aggregate;
|
|
|
|
------------------------------------------------
|
|
-- 4.3 Aggregate or Parenthesized Expression --
|
|
------------------------------------------------
|
|
|
|
-- This procedure parses out either an aggregate or a parenthesized
|
|
-- expression (these two constructs are closely related, since a
|
|
-- parenthesized expression looks like an aggregate with a single
|
|
-- positional component).
|
|
|
|
-- AGGREGATE ::=
|
|
-- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE
|
|
|
|
-- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST)
|
|
|
|
-- RECORD_COMPONENT_ASSOCIATION_LIST ::=
|
|
-- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION}
|
|
-- | null record
|
|
|
|
-- RECORD_COMPONENT_ASSOCIATION ::=
|
|
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
|
|
|
|
-- COMPONENT_CHOICE_LIST ::=
|
|
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
|
|
-- | others
|
|
|
|
-- EXTENSION_AGGREGATE ::=
|
|
-- (ANCESTOR_PART with RECORD_COMPONENT_ASSOCIATION_LIST)
|
|
|
|
-- ANCESTOR_PART ::= EXPRESSION | SUBTYPE_MARK
|
|
|
|
-- ARRAY_AGGREGATE ::=
|
|
-- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE
|
|
|
|
-- POSITIONAL_ARRAY_AGGREGATE ::=
|
|
-- (EXPRESSION, EXPRESSION {, EXPRESSION})
|
|
-- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION)
|
|
-- | (EXPRESSION {, EXPRESSION}, others => <>)
|
|
|
|
-- NAMED_ARRAY_AGGREGATE ::=
|
|
-- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION})
|
|
|
|
-- PRIMARY ::= (EXPRESSION);
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
-- Note: POSITIONAL_ARRAY_AGGREGATE rule has been extended to give support
|
|
-- to Ada 2005 limited aggregates (AI-287)
|
|
|
|
function P_Aggregate_Or_Paren_Expr return Node_Id is
|
|
Aggregate_Node : Node_Id;
|
|
Expr_List : List_Id;
|
|
Assoc_List : List_Id;
|
|
Expr_Node : Node_Id;
|
|
Lparen_Sloc : Source_Ptr;
|
|
Scan_State : Saved_Scan_State;
|
|
|
|
procedure Box_Error;
|
|
-- Called if <> is encountered as positional aggregate element. Issues
|
|
-- error message and sets Expr_Node to Error.
|
|
|
|
---------------
|
|
-- Box_Error --
|
|
---------------
|
|
|
|
procedure Box_Error is
|
|
begin
|
|
if Ada_Version < Ada_2005 then
|
|
Error_Msg_SC ("box in aggregate is an Ada 2005 extension");
|
|
end if;
|
|
|
|
-- Ada 2005 (AI-287): The box notation is allowed only with named
|
|
-- notation because positional notation might be error prone. For
|
|
-- example, in "(X, <>, Y, <>)", there is no type associated with
|
|
-- the boxes, so you might not be leaving out the components you
|
|
-- thought you were leaving out.
|
|
|
|
Error_Msg_SC ("(Ada 2005) box only allowed with named notation");
|
|
Scan; -- past box
|
|
Expr_Node := Error;
|
|
end Box_Error;
|
|
|
|
-- Start of processing for P_Aggregate_Or_Paren_Expr
|
|
|
|
begin
|
|
Lparen_Sloc := Token_Ptr;
|
|
T_Left_Paren;
|
|
|
|
-- Note on parentheses count. For cases like an if expression, the
|
|
-- parens here really count as real parentheses for the paren count,
|
|
-- so we adjust the paren count accordingly after scanning the expr.
|
|
|
|
-- If expression
|
|
|
|
if Token = Tok_If then
|
|
Expr_Node := P_If_Expression;
|
|
T_Right_Paren;
|
|
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
|
|
return Expr_Node;
|
|
|
|
-- Case expression
|
|
|
|
elsif Token = Tok_Case then
|
|
Expr_Node := P_Case_Expression;
|
|
T_Right_Paren;
|
|
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
|
|
return Expr_Node;
|
|
|
|
-- Quantified expression
|
|
|
|
elsif Token = Tok_For then
|
|
Expr_Node := P_Quantified_Expression;
|
|
T_Right_Paren;
|
|
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
|
|
return Expr_Node;
|
|
|
|
-- Note: the mechanism used here of rescanning the initial expression
|
|
-- is distinctly unpleasant, but it saves a lot of fiddling in scanning
|
|
-- out the discrete choice list.
|
|
|
|
-- Deal with expression and extension aggregates first
|
|
|
|
elsif Token /= Tok_Others then
|
|
Save_Scan_State (Scan_State); -- at start of expression
|
|
|
|
-- Deal with (NULL RECORD)
|
|
|
|
if Token = Tok_Null then
|
|
Scan; -- past NULL
|
|
|
|
if Token = Tok_Record then
|
|
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
|
|
Set_Null_Record_Present (Aggregate_Node, True);
|
|
Scan; -- past RECORD
|
|
T_Right_Paren;
|
|
return Aggregate_Node;
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to NULL that must be expr
|
|
end if;
|
|
end if;
|
|
|
|
-- Scan expression, handling box appearing as positional argument
|
|
|
|
if Token = Tok_Box then
|
|
Box_Error;
|
|
else
|
|
Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
|
|
end if;
|
|
|
|
-- Extension aggregate
|
|
|
|
if Token = Tok_With then
|
|
if Nkind (Expr_Node) = N_Attribute_Reference
|
|
and then Attribute_Name (Expr_Node) = Name_Range
|
|
then
|
|
Bad_Range_Attribute (Sloc (Expr_Node));
|
|
return Error;
|
|
end if;
|
|
|
|
if Ada_Version = Ada_83 then
|
|
Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
|
|
end if;
|
|
|
|
Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
|
|
Set_Ancestor_Part (Aggregate_Node, Expr_Node);
|
|
Scan; -- past WITH
|
|
|
|
-- Deal with WITH NULL RECORD case
|
|
|
|
if Token = Tok_Null then
|
|
Save_Scan_State (Scan_State); -- at NULL
|
|
Scan; -- past NULL
|
|
|
|
if Token = Tok_Record then
|
|
Scan; -- past RECORD
|
|
Set_Null_Record_Present (Aggregate_Node, True);
|
|
T_Right_Paren;
|
|
return Aggregate_Node;
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to NULL that must be expr
|
|
end if;
|
|
end if;
|
|
|
|
if Token /= Tok_Others then
|
|
Save_Scan_State (Scan_State);
|
|
Expr_Node := P_Expression;
|
|
else
|
|
Expr_Node := Empty;
|
|
end if;
|
|
|
|
-- Expression
|
|
|
|
elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then
|
|
if Nkind (Expr_Node) = N_Attribute_Reference
|
|
and then Attribute_Name (Expr_Node) = Name_Range
|
|
then
|
|
Error_Msg
|
|
("|parentheses not allowed for range attribute", Lparen_Sloc);
|
|
Scan; -- past right paren
|
|
return Expr_Node;
|
|
end if;
|
|
|
|
-- Bump paren count of expression
|
|
|
|
if Expr_Node /= Error then
|
|
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
|
|
end if;
|
|
|
|
T_Right_Paren; -- past right paren (error message if none)
|
|
return Expr_Node;
|
|
|
|
-- Normal aggregate
|
|
|
|
else
|
|
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
|
|
end if;
|
|
|
|
-- Others
|
|
|
|
else
|
|
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
|
|
Expr_Node := Empty;
|
|
end if;
|
|
|
|
-- Prepare to scan list of component associations
|
|
|
|
Expr_List := No_List; -- don't set yet, maybe all named entries
|
|
Assoc_List := No_List; -- don't set yet, maybe all positional entries
|
|
|
|
-- This loop scans through component associations. On entry to the
|
|
-- loop, an expression has been scanned at the start of the current
|
|
-- association unless initial token was OTHERS, in which case
|
|
-- Expr_Node is set to Empty.
|
|
|
|
loop
|
|
-- Deal with others association first. This is a named association
|
|
|
|
if No (Expr_Node) then
|
|
if No (Assoc_List) then
|
|
Assoc_List := New_List;
|
|
end if;
|
|
|
|
Append (P_Record_Or_Array_Component_Association, Assoc_List);
|
|
|
|
-- Improper use of WITH
|
|
|
|
elsif Token = Tok_With then
|
|
Error_Msg_SC ("WITH must be preceded by single expression in " &
|
|
"extension aggregate");
|
|
raise Error_Resync;
|
|
|
|
-- Range attribute can only appear as part of a discrete choice list
|
|
|
|
elsif Nkind (Expr_Node) = N_Attribute_Reference
|
|
and then Attribute_Name (Expr_Node) = Name_Range
|
|
and then Token /= Tok_Arrow
|
|
and then Token /= Tok_Vertical_Bar
|
|
then
|
|
Bad_Range_Attribute (Sloc (Expr_Node));
|
|
return Error;
|
|
|
|
-- Assume positional case if comma, right paren, or literal or
|
|
-- identifier or OTHERS follows (the latter cases are missing
|
|
-- comma cases). Also assume positional if a semicolon follows,
|
|
-- which can happen if there are missing parens
|
|
|
|
elsif Token = Tok_Comma
|
|
or else Token = Tok_Right_Paren
|
|
or else Token = Tok_Others
|
|
or else Token in Token_Class_Lit_Or_Name
|
|
or else Token = Tok_Semicolon
|
|
then
|
|
if Present (Assoc_List) then
|
|
Error_Msg_BC -- CODEFIX
|
|
("""='>"" expected (positional association cannot follow " &
|
|
"named association)");
|
|
end if;
|
|
|
|
if No (Expr_List) then
|
|
Expr_List := New_List;
|
|
end if;
|
|
|
|
Append (Expr_Node, Expr_List);
|
|
|
|
-- Check for aggregate followed by left parent, maybe missing comma
|
|
|
|
elsif Nkind (Expr_Node) = N_Aggregate
|
|
and then Token = Tok_Left_Paren
|
|
then
|
|
T_Comma;
|
|
|
|
if No (Expr_List) then
|
|
Expr_List := New_List;
|
|
end if;
|
|
|
|
Append (Expr_Node, Expr_List);
|
|
|
|
-- Anything else is assumed to be a named association
|
|
|
|
else
|
|
Restore_Scan_State (Scan_State); -- to start of expression
|
|
|
|
if No (Assoc_List) then
|
|
Assoc_List := New_List;
|
|
end if;
|
|
|
|
Append (P_Record_Or_Array_Component_Association, Assoc_List);
|
|
end if;
|
|
|
|
exit when not Comma_Present;
|
|
|
|
-- If we are at an expression terminator, something is seriously
|
|
-- wrong, so let's get out now, before we start eating up stuff
|
|
-- that doesn't belong to us.
|
|
|
|
if Token in Token_Class_Eterm then
|
|
Error_Msg_AP
|
|
("expecting expression or component association");
|
|
exit;
|
|
end if;
|
|
|
|
-- Deal with misused box
|
|
|
|
if Token = Tok_Box then
|
|
Box_Error;
|
|
|
|
-- Otherwise initiate for reentry to top of loop by scanning an
|
|
-- initial expression, unless the first token is OTHERS.
|
|
|
|
elsif Token = Tok_Others then
|
|
Expr_Node := Empty;
|
|
|
|
else
|
|
Save_Scan_State (Scan_State); -- at start of expression
|
|
Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
|
|
|
|
end if;
|
|
end loop;
|
|
|
|
-- All component associations (positional and named) have been scanned
|
|
|
|
T_Right_Paren;
|
|
Set_Expressions (Aggregate_Node, Expr_List);
|
|
Set_Component_Associations (Aggregate_Node, Assoc_List);
|
|
return Aggregate_Node;
|
|
end P_Aggregate_Or_Paren_Expr;
|
|
|
|
------------------------------------------------
|
|
-- 4.3 Record or Array Component Association --
|
|
------------------------------------------------
|
|
|
|
-- RECORD_COMPONENT_ASSOCIATION ::=
|
|
-- [COMPONENT_CHOICE_LIST =>] EXPRESSION
|
|
-- | COMPONENT_CHOICE_LIST => <>
|
|
|
|
-- COMPONENT_CHOICE_LIST =>
|
|
-- component_SELECTOR_NAME {| component_SELECTOR_NAME}
|
|
-- | others
|
|
|
|
-- ARRAY_COMPONENT_ASSOCIATION ::=
|
|
-- DISCRETE_CHOICE_LIST => EXPRESSION
|
|
-- | DISCRETE_CHOICE_LIST => <>
|
|
|
|
-- Note: this routine only handles the named cases, including others.
|
|
-- Cases where the component choice list is not present have already
|
|
-- been handled directly.
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
-- Note: RECORD_COMPONENT_ASSOCIATION and ARRAY_COMPONENT_ASSOCIATION
|
|
-- rules have been extended to give support to Ada 2005 limited
|
|
-- aggregates (AI-287)
|
|
|
|
function P_Record_Or_Array_Component_Association return Node_Id is
|
|
Assoc_Node : Node_Id;
|
|
|
|
begin
|
|
Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
|
|
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
|
|
Set_Sloc (Assoc_Node, Token_Ptr);
|
|
TF_Arrow;
|
|
|
|
if Token = Tok_Box then
|
|
|
|
-- Ada 2005(AI-287): The box notation is used to indicate the
|
|
-- default initialization of aggregate components
|
|
|
|
if Ada_Version < Ada_2005 then
|
|
Error_Msg_SP
|
|
("component association with '<'> is an Ada 2005 extension");
|
|
Error_Msg_SP ("\unit must be compiled with -gnat05 switch");
|
|
end if;
|
|
|
|
Set_Box_Present (Assoc_Node);
|
|
Scan; -- Past box
|
|
else
|
|
Set_Expression (Assoc_Node, P_Expression);
|
|
end if;
|
|
|
|
return Assoc_Node;
|
|
end P_Record_Or_Array_Component_Association;
|
|
|
|
-----------------------------
|
|
-- 4.3.1 Record Aggregate --
|
|
-----------------------------
|
|
|
|
-- Case of enumeration aggregate is parsed by P_Aggregate (4.3)
|
|
-- All other cases are parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
----------------------------------------------
|
|
-- 4.3.1 Record Component Association List --
|
|
----------------------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
----------------------------------
|
|
-- 4.3.1 Component Choice List --
|
|
----------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
--------------------------------
|
|
-- 4.3.1 Extension Aggregate --
|
|
--------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
--------------------------
|
|
-- 4.3.1 Ancestor Part --
|
|
--------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
----------------------------
|
|
-- 4.3.1 Array Aggregate --
|
|
----------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
---------------------------------------
|
|
-- 4.3.1 Positional Array Aggregate --
|
|
---------------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
----------------------------------
|
|
-- 4.3.1 Named Array Aggregate --
|
|
----------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
----------------------------------------
|
|
-- 4.3.1 Array Component Association --
|
|
----------------------------------------
|
|
|
|
-- Parsed by P_Aggregate_Or_Paren_Expr (4.3)
|
|
|
|
---------------------
|
|
-- 4.4 Expression --
|
|
---------------------
|
|
|
|
-- This procedure parses EXPRESSION or CHOICE_EXPRESSION
|
|
|
|
-- EXPRESSION ::=
|
|
-- RELATION {LOGICAL_OPERATOR RELATION}
|
|
|
|
-- CHOICE_EXPRESSION ::=
|
|
-- CHOICE_RELATION {LOGICAL_OPERATOR CHOICE_RELATION}
|
|
|
|
-- LOGICAL_OPERATOR ::= and | and then | or | or else | xor
|
|
|
|
-- On return, Expr_Form indicates the categorization of the expression
|
|
-- EF_Range_Attr is not a possible value (if a range attribute is found,
|
|
-- an error message is given, and Error is returned).
|
|
|
|
-- Error recovery: cannot raise Error_Resync
|
|
|
|
function P_Expression return Node_Id is
|
|
Logical_Op : Node_Kind;
|
|
Prev_Logical_Op : Node_Kind;
|
|
Op_Location : Source_Ptr;
|
|
Node1 : Node_Id;
|
|
Node2 : Node_Id;
|
|
|
|
begin
|
|
Node1 := P_Relation;
|
|
|
|
if Token in Token_Class_Logop then
|
|
Prev_Logical_Op := N_Empty;
|
|
|
|
loop
|
|
Op_Location := Token_Ptr;
|
|
Logical_Op := P_Logical_Operator;
|
|
|
|
if Prev_Logical_Op /= N_Empty and then
|
|
Logical_Op /= Prev_Logical_Op
|
|
then
|
|
Error_Msg
|
|
("mixed logical operators in expression", Op_Location);
|
|
Prev_Logical_Op := N_Empty;
|
|
else
|
|
Prev_Logical_Op := Logical_Op;
|
|
end if;
|
|
|
|
Node2 := Node1;
|
|
Node1 := New_Op_Node (Logical_Op, Op_Location);
|
|
Set_Left_Opnd (Node1, Node2);
|
|
Set_Right_Opnd (Node1, P_Relation);
|
|
|
|
-- Check for case of errant comma or semicolon
|
|
|
|
if Token = Tok_Comma or else Token = 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 = Tok_And or else Token = Tok_Or then
|
|
Logop := P_Logical_Operator;
|
|
Restore_Scan_State (Scan_State); -- to comma/semicolon
|
|
|
|
if Nkind_In (Logop, 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 = Tok_Case or else Token = Tok_If or else Token = Tok_For then
|
|
return P_Unparen_Cond_Case_Quant_Expression;
|
|
|
|
-- Normal case, not case/conditional/quantified expression
|
|
|
|
else
|
|
return P_Expression;
|
|
end if;
|
|
end P_Expression_If_OK;
|
|
|
|
-- This function is identical to the normal P_Expression, except that it
|
|
-- checks that the expression scan did not stop on a right paren. It is
|
|
-- called in all contexts where a right parenthesis cannot legitimately
|
|
-- follow an expression.
|
|
|
|
-- Error recovery: can not raise Error_Resync
|
|
|
|
function P_Expression_No_Right_Paren return Node_Id is
|
|
Expr : constant Node_Id := P_Expression;
|
|
begin
|
|
Ignore (Tok_Right_Paren);
|
|
return Expr;
|
|
end P_Expression_No_Right_Paren;
|
|
|
|
----------------------------------------
|
|
-- 4.4 Expression_Or_Range_Attribute --
|
|
----------------------------------------
|
|
|
|
-- EXPRESSION ::=
|
|
-- RELATION {and RELATION} | RELATION {and then RELATION}
|
|
-- | RELATION {or RELATION} | RELATION {or else RELATION}
|
|
-- | RELATION {xor RELATION}
|
|
|
|
-- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR
|
|
|
|
-- RANGE_ATTRIBUTE_DESIGNATOR ::= range [(static_EXPRESSION)]
|
|
|
|
-- On return, Expr_Form indicates the categorization of the expression
|
|
-- and EF_Range_Attr is one of the possibilities.
|
|
|
|
-- Error recovery: cannot raise Error_Resync
|
|
|
|
-- In the grammar, a RANGE attribute is simply a name, but its use is
|
|
-- highly restricted, so in the parser, we do not regard it as a name.
|
|
-- Instead, P_Name returns without scanning the 'RANGE part of the
|
|
-- attribute, and P_Expression_Or_Range_Attribute handles the range
|
|
-- attribute reference. In the normal case where a range attribute is
|
|
-- not allowed, an error message is issued by P_Expression.
|
|
|
|
function P_Expression_Or_Range_Attribute return Node_Id is
|
|
Logical_Op : Node_Kind;
|
|
Prev_Logical_Op : Node_Kind;
|
|
Op_Location : Source_Ptr;
|
|
Node1 : Node_Id;
|
|
Node2 : Node_Id;
|
|
Attr_Node : Node_Id;
|
|
|
|
begin
|
|
Node1 := P_Relation;
|
|
|
|
if Token = Tok_Apostrophe then
|
|
Attr_Node := P_Range_Attribute_Reference (Node1);
|
|
Expr_Form := EF_Range_Attr;
|
|
return Attr_Node;
|
|
|
|
elsif Token in Token_Class_Logop then
|
|
Prev_Logical_Op := N_Empty;
|
|
|
|
loop
|
|
Op_Location := Token_Ptr;
|
|
Logical_Op := P_Logical_Operator;
|
|
|
|
if Prev_Logical_Op /= N_Empty and then
|
|
Logical_Op /= Prev_Logical_Op
|
|
then
|
|
Error_Msg
|
|
("mixed logical operators in expression", Op_Location);
|
|
Prev_Logical_Op := N_Empty;
|
|
else
|
|
Prev_Logical_Op := Logical_Op;
|
|
end if;
|
|
|
|
Node2 := Node1;
|
|
Node1 := New_Op_Node (Logical_Op, Op_Location);
|
|
Set_Left_Opnd (Node1, Node2);
|
|
Set_Right_Opnd (Node1, P_Relation);
|
|
exit when Token not in Token_Class_Logop;
|
|
end loop;
|
|
|
|
Expr_Form := EF_Non_Simple;
|
|
end if;
|
|
|
|
if Token = Tok_Apostrophe then
|
|
Bad_Range_Attribute (Token_Ptr);
|
|
return Error;
|
|
else
|
|
return Node1;
|
|
end if;
|
|
end P_Expression_Or_Range_Attribute;
|
|
|
|
-- Version that allows a non-parenthesized case, conditional, or quantified
|
|
-- expression if the call immediately follows a left paren, and followed
|
|
-- by a right parenthesis. These forms are allowed if these conditions
|
|
-- are not met, but an error message will be issued.
|
|
|
|
function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
|
|
begin
|
|
-- Case of conditional, case or quantified expression
|
|
|
|
if Token = Tok_Case or else Token = Tok_If or else Token = Tok_For then
|
|
return P_Unparen_Cond_Case_Quant_Expression;
|
|
|
|
-- Normal case, not one of the above expression types
|
|
|
|
else
|
|
return P_Expression_Or_Range_Attribute;
|
|
end if;
|
|
end P_Expression_Or_Range_Attribute_If_OK;
|
|
|
|
-------------------
|
|
-- 4.4 Relation --
|
|
-------------------
|
|
|
|
-- This procedure scans both relations and choice relations
|
|
|
|
-- CHOICE_RELATION ::=
|
|
-- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION]
|
|
|
|
-- RELATION ::=
|
|
-- SIMPLE_EXPRESSION [not] in MEMBERSHIP_CHOICE_LIST
|
|
-- | 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
|
|
Empty_String_Val : String_Id;
|
|
-- String_Id for ""
|
|
|
|
Strlit_Concat_Val : String_Id;
|
|
-- Contains the folded value (which will be correct if the
|
|
-- "&" operators are the predefined ones).
|
|
|
|
Cur_Node : Node_Id;
|
|
-- For walking up the tree
|
|
|
|
New_Node : Node_Id;
|
|
-- Folded node to replace Node1
|
|
|
|
Loc : constant Source_Ptr := Sloc (First_Node);
|
|
|
|
begin
|
|
-- Walk up the tree starting at the leftmost string literal
|
|
-- (First_Node), building up the Strlit_Concat_Val as we
|
|
-- go. Note that we do not use recursion here -- the whole
|
|
-- point is to avoid recursively walking that enormous tree.
|
|
|
|
Start_String;
|
|
Store_String_Chars (Strval (First_Node));
|
|
|
|
Cur_Node := Parent (First_Node);
|
|
while Present (Cur_Node) loop
|
|
pragma Assert (Nkind (Cur_Node) = N_Op_Concat and then
|
|
Nkind (Right_Opnd (Cur_Node)) = N_String_Literal);
|
|
|
|
Store_String_Chars (Strval (Right_Opnd (Cur_Node)));
|
|
Cur_Node := Parent (Cur_Node);
|
|
end loop;
|
|
|
|
Strlit_Concat_Val := End_String;
|
|
|
|
-- Create new folded node, and rewrite result with a concat-
|
|
-- enation of an empty string literal and the folded node.
|
|
|
|
Start_String;
|
|
Empty_String_Val := End_String;
|
|
New_Node :=
|
|
Make_Op_Concat (Loc,
|
|
Make_String_Literal (Loc, Empty_String_Val),
|
|
Make_String_Literal (Loc, Strlit_Concat_Val,
|
|
Is_Folded_In_Parser => True));
|
|
Rewrite (Node1, New_Node);
|
|
end;
|
|
end if;
|
|
end;
|
|
|
|
-- All done, we clearly do not have name or numeric literal so this
|
|
-- is a case of a simple expression which is some other possibility.
|
|
|
|
Expr_Form := EF_Simple;
|
|
end if;
|
|
|
|
-- Come here at end of simple expression, where we do a couple of
|
|
-- special checks to improve error recovery.
|
|
|
|
-- Special test to improve error recovery. If the current token
|
|
-- is a period, then someone is trying to do selection on something
|
|
-- that is not a name, e.g. a qualified expression.
|
|
|
|
if Token = Tok_Dot then
|
|
Error_Msg_SC ("prefix for selection is not a name");
|
|
|
|
-- If qualified expression, comment and continue, otherwise something
|
|
-- is pretty nasty so do an Error_Resync call.
|
|
|
|
if Ada_Version < Ada_2012
|
|
and then Nkind (Node1) = N_Qualified_Expression
|
|
then
|
|
Error_Msg_SC ("\would be legal in Ada 2012 mode");
|
|
else
|
|
raise Error_Resync;
|
|
end if;
|
|
end if;
|
|
|
|
-- Special test to improve error recovery: If the current token is
|
|
-- not the first token on a line (as determined by checking the
|
|
-- previous token position with the start of the current line),
|
|
-- then we insist that we have an appropriate terminating token.
|
|
-- Consider the following two examples:
|
|
|
|
-- 1) if A nad B then ...
|
|
|
|
-- 2) A := B
|
|
-- C := D
|
|
|
|
-- In the first example, we would like to issue a binary operator
|
|
-- expected message and resynchronize to the then. In the second
|
|
-- example, we do not want to issue a binary operator message, so
|
|
-- that instead we will get the missing semicolon message. This
|
|
-- distinction is of course a heuristic which does not always work,
|
|
-- but in practice it is quite effective.
|
|
|
|
-- Note: the one case in which we do not go through this circuit is
|
|
-- when we have scanned a range attribute and want to return with
|
|
-- Token pointing to the apostrophe. The apostrophe is not normally
|
|
-- an expression terminator, and is not in Token_Class_Sterm, but
|
|
-- in this special case we know that the expression is complete.
|
|
|
|
if not Token_Is_At_Start_Of_Line
|
|
and then Token not in Token_Class_Sterm
|
|
then
|
|
-- Normally the right error message is indeed that we expected a
|
|
-- binary operator, but in the case of being between a right and left
|
|
-- paren, e.g. in an aggregate, a more likely error is missing comma.
|
|
|
|
if Prev_Token = Tok_Right_Paren and then Token = Tok_Left_Paren then
|
|
T_Comma;
|
|
|
|
-- 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
|
|
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
function P_Primary return Node_Id is
|
|
Scan_State : Saved_Scan_State;
|
|
Node1 : Node_Id;
|
|
|
|
Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
|
|
-- Remember if previous token is a left parenthesis. This is used to
|
|
-- deal with checking whether IF/CASE/FOR expressions appearing as
|
|
-- primaries require extra parenthesization.
|
|
|
|
begin
|
|
-- The loop runs more than once only if misplaced pragmas are found
|
|
-- or if a misplaced unary minus is skipped.
|
|
|
|
loop
|
|
case Token is
|
|
|
|
-- Name token can start a name, call or qualified expression, all
|
|
-- of which are acceptable possibilities for primary. Note also
|
|
-- that string literal is included in name (as operator symbol)
|
|
-- and type conversion is included in name (as indexed component).
|
|
|
|
when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
|
|
Node1 := P_Name;
|
|
|
|
-- All done unless apostrophe follows
|
|
|
|
if Token /= Tok_Apostrophe then
|
|
return Node1;
|
|
|
|
-- Apostrophe following means that we have either just parsed
|
|
-- the subtype mark of a qualified expression, or the prefix
|
|
-- or a range attribute.
|
|
|
|
else -- Token = Tok_Apostrophe
|
|
Save_Scan_State (Scan_State); -- at apostrophe
|
|
Scan; -- past apostrophe
|
|
|
|
-- If range attribute, then this is always an error, since
|
|
-- the only legitimate case (where the scanned expression is
|
|
-- a qualified simple name) is handled at the level of the
|
|
-- Simple_Expression processing. This case corresponds to a
|
|
-- usage such as 3 + A'Range, which is always illegal.
|
|
|
|
if Token = Tok_Range then
|
|
Restore_Scan_State (Scan_State); -- to apostrophe
|
|
Bad_Range_Attribute (Token_Ptr);
|
|
return Error;
|
|
|
|
-- If left paren, then we have a qualified expression.
|
|
-- Note that P_Name guarantees that in this case, where
|
|
-- Token = Tok_Apostrophe on return, the only two possible
|
|
-- tokens following the apostrophe are left paren and
|
|
-- RANGE, so we know we have a left paren here.
|
|
|
|
else -- Token = Tok_Left_Paren
|
|
return P_Qualified_Expression (Node1);
|
|
|
|
end if;
|
|
end if;
|
|
|
|
-- Numeric or string literal
|
|
|
|
when Tok_Integer_Literal |
|
|
Tok_Real_Literal |
|
|
Tok_String_Literal =>
|
|
|
|
Node1 := Token_Node;
|
|
Scan; -- past number
|
|
return Node1;
|
|
|
|
-- Left paren, starts aggregate or parenthesized expression
|
|
|
|
when Tok_Left_Paren =>
|
|
declare
|
|
Expr : constant Node_Id := P_Aggregate_Or_Paren_Expr;
|
|
|
|
begin
|
|
if Nkind (Expr) = N_Attribute_Reference
|
|
and then Attribute_Name (Expr) = Name_Range
|
|
then
|
|
Bad_Range_Attribute (Sloc (Expr));
|
|
end if;
|
|
|
|
return Expr;
|
|
end;
|
|
|
|
-- Allocator
|
|
|
|
when Tok_New =>
|
|
return P_Allocator;
|
|
|
|
-- Null
|
|
|
|
when Tok_Null =>
|
|
Scan; -- past NULL
|
|
return New_Node (N_Null, Prev_Token_Ptr);
|
|
|
|
-- Pragma, not allowed here, so just skip past it
|
|
|
|
when Tok_Pragma =>
|
|
P_Pragmas_Misplaced;
|
|
|
|
-- Deal with IF (possible unparenthesized if expression)
|
|
|
|
when Tok_If =>
|
|
|
|
-- If this looks like a real if, defined as an IF appearing at
|
|
-- the start of a new line, then we consider we have a missing
|
|
-- operand. If in Ada 2012 and the IF is not properly indented
|
|
-- for a statement, we prefer to issue a message about an ill-
|
|
-- parenthesized if expression.
|
|
|
|
if Token_Is_At_Start_Of_Line
|
|
and then not
|
|
(Ada_Version >= Ada_2012
|
|
and then Style_Check_Indentation /= 0
|
|
and then Start_Column rem Style_Check_Indentation /= 0)
|
|
then
|
|
Error_Msg_AP ("missing operand");
|
|
return Error;
|
|
|
|
-- If this looks like an if expression, then treat it that way
|
|
-- with an error message if not explicitly surrounded by
|
|
-- parentheses.
|
|
|
|
elsif Ada_Version >= Ada_2012 then
|
|
Node1 := P_If_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg
|
|
("if expression must be parenthesized", Sloc (Node1));
|
|
end if;
|
|
|
|
return Node1;
|
|
|
|
-- Otherwise treat as misused identifier
|
|
|
|
else
|
|
return P_Identifier;
|
|
end if;
|
|
|
|
-- Deal with CASE (possible unparenthesized case expression)
|
|
|
|
when Tok_Case =>
|
|
|
|
-- If this looks like a real case, defined as a CASE appearing
|
|
-- the start of a new line, then we consider we have a missing
|
|
-- operand. If in Ada 2012 and the CASE is not properly
|
|
-- indented for a statement, we prefer to issue a message about
|
|
-- an ill-parenthesized case expression.
|
|
|
|
if Token_Is_At_Start_Of_Line
|
|
and then not
|
|
(Ada_Version >= Ada_2012
|
|
and then Style_Check_Indentation /= 0
|
|
and then Start_Column rem Style_Check_Indentation /= 0)
|
|
then
|
|
Error_Msg_AP ("missing operand");
|
|
return Error;
|
|
|
|
-- If this looks like a case expression, then treat it that way
|
|
-- with an error message if not within parentheses.
|
|
|
|
elsif Ada_Version >= Ada_2012 then
|
|
Node1 := P_Case_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg
|
|
("case expression must be parenthesized", Sloc (Node1));
|
|
end if;
|
|
|
|
return Node1;
|
|
|
|
-- Otherwise treat as misused identifier
|
|
|
|
else
|
|
return P_Identifier;
|
|
end if;
|
|
|
|
-- For [all | some] indicates a quantified expression
|
|
|
|
when Tok_For =>
|
|
if Token_Is_At_Start_Of_Line then
|
|
Error_Msg_AP ("misplaced loop");
|
|
return Error;
|
|
|
|
elsif Ada_Version >= Ada_2012 then
|
|
Node1 := P_Quantified_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg
|
|
("quantified expression must be parenthesized",
|
|
Sloc (Node1));
|
|
end if;
|
|
|
|
return Node1;
|
|
|
|
-- Otherwise treat as misused identifier
|
|
|
|
else
|
|
return P_Identifier;
|
|
end if;
|
|
|
|
-- Minus may well be an improper attempt at a unary minus. Give
|
|
-- a message, skip the minus and keep going.
|
|
|
|
when Tok_Minus =>
|
|
Error_Msg_SC ("parentheses required for unary minus");
|
|
Scan; -- past minus
|
|
|
|
-- Anything else is illegal as the first token of a primary, but
|
|
-- we test for some common errors, to improve error messages.
|
|
|
|
when others =>
|
|
if Is_Reserved_Identifier then
|
|
return P_Identifier;
|
|
|
|
elsif Prev_Token = Tok_Comma then
|
|
Error_Msg_SP -- CODEFIX
|
|
("|extra "","" ignored");
|
|
raise Error_Resync;
|
|
|
|
else
|
|
Error_Msg_AP ("missing operand");
|
|
raise Error_Resync;
|
|
end if;
|
|
|
|
end case;
|
|
end loop;
|
|
end P_Primary;
|
|
|
|
-------------------------------
|
|
-- 4.4 Quantified_Expression --
|
|
-------------------------------
|
|
|
|
-- QUANTIFIED_EXPRESSION ::=
|
|
-- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
|
|
-- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
|
|
|
|
function P_Quantified_Expression return Node_Id is
|
|
I_Spec : Node_Id;
|
|
Node1 : Node_Id;
|
|
|
|
begin
|
|
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 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;
|
|
|
|
-- If comma/WHEN, skip comma and we have another alternative
|
|
|
|
elsif Token = Tok_Comma then
|
|
Save_Scan_State (Save_State);
|
|
Scan; -- past comma
|
|
|
|
if Token /= Tok_When then
|
|
Restore_Scan_State (Save_State);
|
|
exit;
|
|
end if;
|
|
|
|
-- If no comma or WHEN, definitely done
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If we have an END CASE, diagnose as not needed
|
|
|
|
if Token = Tok_End then
|
|
Error_Msg_SC ("`END CASE` not allowed at end of case expression");
|
|
Scan; -- past END
|
|
|
|
if Token = Tok_Case then
|
|
Scan; -- past CASE;
|
|
end if;
|
|
end if;
|
|
|
|
-- Return the Case_Expression node
|
|
|
|
return Case_Node;
|
|
end P_Case_Expression;
|
|
|
|
-----------------------------------
|
|
-- P_Case_Expression_Alternative --
|
|
-----------------------------------
|
|
|
|
-- CASE_STATEMENT_ALTERNATIVE ::=
|
|
-- when DISCRETE_CHOICE_LIST =>
|
|
-- EXPRESSION
|
|
|
|
-- The caller has checked that and scanned past the initial WHEN token
|
|
-- Error recovery: can raise Error_Resync
|
|
|
|
function P_Case_Expression_Alternative return Node_Id is
|
|
Case_Alt_Node : Node_Id;
|
|
begin
|
|
Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
|
|
Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
|
|
TF_Arrow;
|
|
Set_Expression (Case_Alt_Node, P_Expression);
|
|
return Case_Alt_Node;
|
|
end P_Case_Expression_Alternative;
|
|
|
|
---------------------
|
|
-- P_If_Expression --
|
|
---------------------
|
|
|
|
function P_If_Expression return Node_Id is
|
|
|
|
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 = Tok_Else or else Token = Tok_Elsif then
|
|
Error_Msg_SP -- CODEFIX
|
|
("|extra "";"" ignored");
|
|
|
|
else
|
|
Restore_Scan_State (State);
|
|
end if;
|
|
end if;
|
|
|
|
-- Scan out ELSIF sequence if present
|
|
|
|
if Token = Tok_Elsif then
|
|
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_Membership_Test --
|
|
-----------------------
|
|
|
|
-- MEMBERSHIP_CHOICE_LIST ::= MEMBERHIP_CHOICE {'|' MEMBERSHIP_CHOICE}
|
|
-- MEMBERSHIP_CHOICE ::= CHOICE_EXPRESSION | range | subtype_mark
|
|
|
|
procedure P_Membership_Test (N : Node_Id) is
|
|
Alt : constant Node_Id :=
|
|
P_Range_Or_Subtype_Mark
|
|
(Allow_Simple_Expression => (Ada_Version >= Ada_2012));
|
|
|
|
begin
|
|
-- Set case
|
|
|
|
if Token = Tok_Vertical_Bar then
|
|
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_Case_Quant_Expression --
|
|
------------------------------------------
|
|
|
|
function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
|
|
Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
|
|
Result : Node_Id;
|
|
|
|
begin
|
|
-- Case expression
|
|
|
|
if Token = Tok_Case then
|
|
Result := P_Case_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg_N ("case expression must be parenthesized!", Result);
|
|
end if;
|
|
|
|
-- If expression
|
|
|
|
elsif Token = Tok_If then
|
|
Result := P_If_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg_N ("if expression must be parenthesized!", Result);
|
|
end if;
|
|
|
|
-- Quantified expression
|
|
|
|
elsif Token = Tok_For then
|
|
Result := P_Quantified_Expression;
|
|
|
|
if not (Lparen and then Token = Tok_Right_Paren) then
|
|
Error_Msg_N
|
|
("quantified expression must be parenthesized!", Result);
|
|
end if;
|
|
|
|
-- No other possibility should exist (caller was supposed to check)
|
|
|
|
else
|
|
raise Program_Error;
|
|
end if;
|
|
|
|
-- Return expression (possibly after having given message)
|
|
|
|
return Result;
|
|
end P_Unparen_Cond_Case_Quant_Expression;
|
|
|
|
end Ch4;
|