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