diff options
Diffstat (limited to 'gcc/ada/par-ch4.adb')
| -rw-r--r-- | gcc/ada/par-ch4.adb | 2298 |
1 files changed, 2298 insertions, 0 deletions
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb new file mode 100644 index 00000000000..30fba5619cc --- /dev/null +++ b/gcc/ada/par-ch4.adb @@ -0,0 +1,2298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.91 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch4 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Aggregate_Or_Paren_Expr return Node_Id; + function P_Allocator 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. + + 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. + + procedure Set_Op_Name (Node : Node_Id); + -- Procedure to set name field (Chars) in operator node + + ------------------------- + -- 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; + + ------------------ + -- Set_Op_Name -- + ------------------ + + procedure Set_Op_Name (Node : Node_Id) is + type Name_Of_Type is array (N_Op) of Name_Id; + Name_Of : Name_Of_Type := Name_Of_Type'( + N_Op_And => Name_Op_And, + N_Op_Or => Name_Op_Or, + N_Op_Xor => Name_Op_Xor, + N_Op_Eq => Name_Op_Eq, + N_Op_Ne => Name_Op_Ne, + N_Op_Lt => Name_Op_Lt, + N_Op_Le => Name_Op_Le, + N_Op_Gt => Name_Op_Gt, + N_Op_Ge => Name_Op_Ge, + N_Op_Add => Name_Op_Add, + N_Op_Subtract => Name_Op_Subtract, + N_Op_Concat => Name_Op_Concat, + N_Op_Multiply => Name_Op_Multiply, + N_Op_Divide => Name_Op_Divide, + N_Op_Mod => Name_Op_Mod, + N_Op_Rem => Name_Op_Rem, + N_Op_Expon => Name_Op_Expon, + N_Op_Plus => Name_Op_Add, + N_Op_Minus => Name_Op_Subtract, + N_Op_Abs => Name_Op_Abs, + N_Op_Not => Name_Op_Not, + + -- We don't really need these shift operators, since they never + -- appear as operators in the source, but the path of least + -- resistance is to put them in (the aggregate must be complete) + + N_Op_Rotate_Left => Name_Rotate_Left, + N_Op_Rotate_Right => Name_Rotate_Right, + N_Op_Shift_Left => Name_Shift_Left, + N_Op_Shift_Right => Name_Shift_Right, + N_Op_Shift_Right_Arithmetic => Name_Shift_Right_Arithmetic); + + begin + if Nkind (Node) in N_Op then + Set_Chars (Node, Name_Of (Nkind (Node))); + end if; + end Set_Op_Name; + + -------------------------- + -- 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 + if Token not in Token_Class_Name then + Error_Msg_AP ("name expected"); + raise Error_Resync; + 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 + + -- If left paren, then this might be a qualified expression, but we + -- are only in the business of scanning out names, 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). + + if 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. + + 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 + -- 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 + -- qualified expression case). + + if 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; + else + Signal_Bad_Attribute; + end if; + end if; + + if Style_Check then + Style.Check_Attribute_Name (False); + end if; + + Delete_Node (Token_Node); + + -- 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 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 the + -- 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 + + if Token = Tok_Left_Paren then + Set_Expressions (Name_Node, New_List); + Scan; -- past left paren + + loop + declare + Expr : constant Node_Id := P_Expression; + + 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. + + -- (..., identifier => expression , ...) + + -- If there is at least one occurence 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; + + -- 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 + T_Right_Paren; + raise Error_Resync; + + 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 identifer => 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; + 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; + + -- 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)); + 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 Expresssion -- + ------------------------------------------------- + + -- 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) + + -- NAMED_ARRAY_AGGREGATE ::= + -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) + + -- PRIMARY ::= (EXPRESSION); + + -- Error recovery: can raise Error_Resync + + 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; + + begin + Lparen_Sloc := Token_Ptr; + T_Left_Paren; + + -- 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 + + if 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; + + Expr_Node := P_Expression_Or_Range_Attribute; + + -- 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_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 + Bad_Range_Attribute (Sloc (Expr_Node)); + return Error; + end if; + + -- Bump paren count of expression, note that if the paren count + -- is already at the maximum, then we leave it alone. This will + -- cause some failures in pathalogical conformance tests, which + -- we do not shed a tear over! + + if Expr_Node /= Error then + if Paren_Count (Expr_Node) /= Paren_Count_Type'Last then + Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1); + end if; + 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; + + -- 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 + ("""=>"" 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); + + -- 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; + + -- Otherwise initiate for reentry to top of loop by scanning an + -- initial expression, unless the first token is OTHERS. + + if Token = Tok_Others then + Expr_Node := Empty; + else + Save_Scan_State (Scan_State); -- at start of expression + Expr_Node := P_Expression; + 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_SELECTOR_NAME {| component_SELECTOR_NAME} + -- | others + + -- ARRAY_COMPONENT_ASSOCIATION ::= + -- DISCRETE_CHOICE_LIST => EXPRESSION + + -- 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 + + 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; + Set_Expression (Assoc_Node, P_Expression); + 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 -- + --------------------- + + -- EXPRESSION ::= + -- RELATION {and RELATION} | RELATION {and then RELATION} + -- | RELATION {or RELATION} | RELATION {or else RELATION} + -- | RELATION {xor RELATION} + + -- 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_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + Set_Op_Name (Node1); + 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 + -- 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. + + function P_Expression_No_Right_Paren return Node_Id is + begin + return No_Right_Paren (P_Expression); + 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_Node (Logical_Op, Op_Location); + Set_Left_Opnd (Node1, Node2); + Set_Right_Opnd (Node1, P_Relation); + Set_Op_Name (Node1); + 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; + + ------------------- + -- 4.4 Relation -- + ------------------- + + -- RELATION ::= + -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] + -- | SIMPLE_EXPRESSION [not] in RANGE + -- | SIMPLE_EXPRESSION [not] in 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_Node (P_Relational_Operator, Optok); + Set_Left_Opnd (Node2, Node1); + Set_Op_Name (Node2); + + -- Case of IN or NOT IN + + if Prev_Token = Tok_In then + Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark); + + -- 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_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + Set_Op_Name (Node2); + Node1 := Node2; + end if; + + loop + exit when Token not in Token_Class_Mulop; + Tokptr := Token_Ptr; + Node2 := New_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); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + loop + exit when Token not in Token_Class_Binary_Addop; + Tokptr := Token_Ptr; + Node2 := New_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); + Set_Op_Name (Node2); + 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_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); + Set_Op_Name (Node1); + else + Node1 := P_Term; + end if; + + -- 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_Node (P_Binary_Adding_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Term); + Set_Op_Name (Node2); + Node1 := Node2; + end loop; + + -- 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"); + raise Error_Resync; + 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 + Error_Msg_AP ("binary operator expected"); + 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 + 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_Node (P_Multiplying_Operator, Tokptr); + Scan; -- past operator + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Factor); + Set_Op_Name (Node2); + 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_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); + Set_Op_Name (Node1); + return Node1; + + elsif Token = Tok_Not then + Node1 := New_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); + Set_Op_Name (Node1); + return Node1; + + else + Node1 := P_Primary; + + if Token = Tok_Double_Asterisk then + Node2 := New_Node (N_Op_Expon, Token_Ptr); + Scan; -- past ** + Set_Left_Opnd (Node2, Node1); + Set_Right_Opnd (Node2, P_Primary); + Set_Op_Name (Node2); + 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) + + -- 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 => + return P_Aggregate_Or_Paren_Expr; + + -- 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; + + -- 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 ("extra "","" ignored"); + raise Error_Resync; + + else + Error_Msg_AP ("missing operand"); + raise Error_Resync; + end if; + + end case; + end loop; + end P_Primary; + + --------------------------- + -- 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 ("""<>"" 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 SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION + + -- 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; + + begin + Alloc_Node := New_Node (N_Allocator, Token_Ptr); + T_New; + 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)); + end if; + + return Alloc_Node; + end P_Allocator; + +end Ch4; |