diff options
Diffstat (limited to 'gcc/ada/par-ch3.adb')
-rw-r--r-- | gcc/ada/par-ch3.adb | 3724 |
1 files changed, 3724 insertions, 0 deletions
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb new file mode 100644 index 00000000000..937f02d0e7c --- /dev/null +++ b/gcc/ada/par-ch3.adb @@ -0,0 +1,3724 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.148 $ +-- -- +-- 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 + +with Sinfo.CN; use Sinfo.CN; + +separate (Par) + +package body Ch3 is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function P_Component_List return Node_Id; + function P_Defining_Character_Literal return Node_Id; + function P_Delta_Constraint return Node_Id; + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; + function P_Digits_Constraint return Node_Id; + function P_Discriminant_Association return Node_Id; + function P_Enumeration_Literal_Specification return Node_Id; + function P_Enumeration_Type_Definition return Node_Id; + function P_Fixed_Point_Definition return Node_Id; + function P_Floating_Point_Definition return Node_Id; + function P_Index_Or_Discriminant_Constraint return Node_Id; + function P_Real_Range_Specification_Opt return Node_Id; + function P_Subtype_Declaration return Node_Id; + function P_Type_Declaration return Node_Id; + function P_Modular_Type_Definition return Node_Id; + function P_Variant return Node_Id; + function P_Variant_Part return Node_Id; + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a single declarative item, or, in the case of a declaration + -- with a list of identifiers, a list of declarations, one for each of + -- the identifiers in the list. The declaration or declarations scanned + -- are appended to the given list. Done indicates whether or not there + -- may be additional declarative items to scan. If Done is True, then + -- a decision has been made that there are no more items to scan. If + -- Done is False, then there may be additional declarations to scan. + -- In_Spec is true if we are scanning a package declaration, and is used + -- to generate an appropriate message if a statement is encountered in + -- such a context. + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Scans out a set of declarations for an identifier or list of + -- identifiers, and appends them to the given list. The parameters have + -- the same significance as for P_Declarative_Items. + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean); + -- Called when a statement is found at a point where a declaration was + -- expected. The parameters are as described for P_Declarative_Items. + + procedure Set_Declaration_Expected; + -- Posts a "declaration expected" error messages at the start of the + -- current token, and if this is the first such message issued, saves + -- the message id in Missing_Begin_Msg, for possible later replacement. + + ------------------- + -- Init_Expr_Opt -- + ------------------- + + function Init_Expr_Opt (P : Boolean := False) return Node_Id is + begin + if Token = Tok_Colon_Equal + or else Token = Tok_Equal + or else Token = Tok_Colon + or else Token = Tok_Is + then + null; + + -- One other possibility. If we have a literal followed by a semicolon, + -- we assume that we have a missing colon-equal. + + elsif Token in Token_Class_Literal then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); + Scan; -- past literal or identifier + + if Token = Tok_Semicolon then + Restore_Scan_State (Scan_State); + else + Restore_Scan_State (Scan_State); + return Empty; + end if; + end; + + -- Otherwise we definitely have no initialization expression + + else + return Empty; + end if; + + -- Merge here if we have an initialization expression + + T_Colon_Equal; + + if P then + return P_Expression; + else + return P_Expression_No_Right_Paren; + end if; + end Init_Expr_Opt; + + ---------------------------- + -- 3.1 Basic Declaration -- + ---------------------------- + + -- Parsed by P_Basic_Declarative_Items (3.9) + + ------------------------------ + -- 3.1 Defining Identifier -- + ------------------------------ + + -- DEFINING_IDENTIFIER ::= IDENTIFIER + + -- Error recovery: can raise Error_Resync + + function P_Defining_Identifier return Node_Id is + Ident_Node : Node_Id; + + begin + -- Scan out the identifier. Note that this code is essentially identical + -- to P_Identifier, except that in the call to Scan_Reserved_Identifier + -- we set Force_Msg to True, since we want at least one message for each + -- separate declaration (but not use) of a reserved identifier. + + if Token = Tok_Identifier then + null; + + -- If we have a reserved identifier, manufacture an identifier with + -- a corresponding name after posting an appropriate error message + + elsif Is_Reserved_Identifier then + Scan_Reserved_Identifier (Force_Msg => True); + + -- Otherwise we have junk that cannot be interpreted as an identifier + + else + T_Identifier; -- to give message + raise Error_Resync; + end if; + + Ident_Node := Token_Node; + Scan; -- past the reserved identifier + + if Ident_Node /= Error then + Change_Identifier_To_Defining_Identifier (Ident_Node); + end if; + + return Ident_Node; + end P_Defining_Identifier; + + ----------------------------- + -- 3.2.1 Type Declaration -- + ----------------------------- + + -- TYPE_DECLARATION ::= + -- FULL_TYPE_DECLARATION + -- | INCOMPLETE_TYPE_DECLARATION + -- | PRIVATE_TYPE_DECLARATION + -- | PRIVATE_EXTENSION_DECLARATION + + -- FULL_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; + -- | CONCURRENT_TYPE_DECLARATION + + -- INCOMPLETE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]; + + -- PRIVATE_TYPE_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] + -- is [abstract] [tagged] [limited] private; + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] new ancestor_SUBTYPE_INDICATION with private; + + -- TYPE_DEFINITION ::= + -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION + -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION + -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION + -- | DERIVED_TYPE_DEFINITION + + -- INTEGER_TYPE_DEFINITION ::= + -- SIGNED_INTEGER_TYPE_DEFINITION + -- MODULAR_TYPE_DEFINITION + + -- Error recovery: can raise Error_Resync + + -- Note: The processing for full type declaration, incomplete type + -- declaration, private type declaration and type definition is + -- included in this function. The processing for concurrent type + -- declarations is NOT here, but rather in chapter 9 (i.e. this + -- function handles only declarations starting with TYPE). + + function P_Type_Declaration return Node_Id is + Type_Loc : Source_Ptr; + Type_Start_Col : Column_Number; + Ident_Node : Node_Id; + Decl_Node : Node_Id; + Discr_List : List_Id; + Unknown_Dis : Boolean; + Discr_Sloc : Source_Ptr; + Abstract_Present : Boolean; + Abstract_Loc : Source_Ptr; + End_Labl : Node_Id; + + Typedef_Node : Node_Id; + -- Normally holds type definition, except in the case of a private + -- extension declaration, in which case it holds the declaration itself + + begin + Type_Loc := Token_Ptr; + Type_Start_Col := Start_Column; + T_Type; + Ident_Node := P_Defining_Identifier; + Discr_Sloc := Token_Ptr; + + if P_Unknown_Discriminant_Part_Opt then + Unknown_Dis := True; + Discr_List := No_List; + else + Unknown_Dis := False; + Discr_List := P_Known_Discriminant_Part_Opt; + end if; + + -- Incomplete type declaration. We complete the processing for this + -- case here and return the resulting incomplete type declaration node + + if Token = Tok_Semicolon then + Scan; -- past ; + Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + return Decl_Node; + + else + Decl_Node := Empty; + end if; + + -- Full type declaration or private type declaration, must have IS + + if Token = Tok_Equal then + TF_Is; + Scan; -- past = used in place of IS + + elsif Token = Tok_Renames then + Error_Msg_SC ("RENAMES should be IS"); + Scan; -- past RENAMES used in place of IS + + else + TF_Is; + end if; + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Abstract) or else + Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Check for misuse of Ada 95 keyword abstract in Ada 83 mode + + if Token_Name = Name_Abstract then + Check_95_Keyword (Tok_Abstract, Tok_Tagged); + Check_95_Keyword (Tok_Abstract, Tok_New); + end if; + + -- Check cases of misuse of ABSTRACT + + if Token = Tok_Abstract then + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + + if Token = Tok_Limited + or else Token = Tok_Private + or else Token = Tok_Record + or else Token = Tok_Null + then + Error_Msg_AP ("TAGGED expected"); + end if; + + else + Abstract_Present := False; + Abstract_Loc := No_Location; + end if; + + -- Check for misuse of Ada 95 keyword Tagged + + if Token_Name = Name_Tagged then + Check_95_Keyword (Tok_Tagged, Tok_Private); + Check_95_Keyword (Tok_Tagged, Tok_Limited); + Check_95_Keyword (Tok_Tagged, Tok_Record); + end if; + + -- Special check for misuse of Aliased + + if Token = Tok_Aliased or else Token_Name = Name_Aliased then + Error_Msg_SC ("ALIASED not allowed in type definition"); + Scan; -- past ALIASED + end if; + + -- The following procesing deals with either a private type declaration + -- or a full type declaration. In the private type case, we build the + -- N_Private_Type_Declaration node, setting its Tagged_Present and + -- Limited_Present flags, on encountering the Private keyword, and + -- leave Typedef_Node set to Empty. For the full type declaration + -- case, Typedef_Node gets set to the type definition. + + Typedef_Node := Empty; + + -- Switch on token following the IS. The loop normally runs once. It + -- only runs more than once if an error is detected, to try again after + -- detecting and fixing up the error. + + loop + case Token is + + when Tok_Access => + Typedef_Node := P_Access_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Array => + Typedef_Node := P_Array_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Delta => + Typedef_Node := P_Fixed_Point_Definition; + TF_Semicolon; + exit; + + when Tok_Digits => + Typedef_Node := P_Floating_Point_Definition; + TF_Semicolon; + exit; + + when Tok_In => + Ignore (Tok_In); + + when Tok_Integer_Literal => + T_Range; + Typedef_Node := P_Signed_Integer_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Null => + Typedef_Node := P_Record_Definition; + TF_Semicolon; + exit; + + when Tok_Left_Paren => + Typedef_Node := P_Enumeration_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Mod => + Typedef_Node := P_Modular_Type_Definition; + TF_Semicolon; + exit; + + when Tok_New => + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + TF_Semicolon; + exit; + + when Tok_Range => + Typedef_Node := P_Signed_Integer_Type_Definition; + TF_Semicolon; + exit; + + when Tok_Record => + Typedef_Node := P_Record_Definition; + + End_Labl := + Make_Identifier (Token_Ptr, + Chars => Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); + TF_Semicolon; + exit; + + when Tok_Tagged => + Scan; -- past TAGGED + + if Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before TAGGED"); + Abstract_Present := True; + Abstract_Loc := Token_Ptr; + Scan; -- past ABSTRACT + end if; + + if Token = Tok_Limited then + Scan; -- past LIMITED + + -- TAGGED LIMITED PRIVATE case + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Set_Limited_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED LIMITED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + Set_Limited_Present (Typedef_Node, True); + end if; + + else + -- TAGGED PRIVATE + + if Token = Tok_Private then + Decl_Node := + New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Tagged_Present (Decl_Node, True); + Scan; -- past PRIVATE + + -- TAGGED RECORD + + else + Typedef_Node := P_Record_Definition; + Set_Tagged_Present (Typedef_Node, True); + end if; + end if; + + TF_Semicolon; + exit; + + when Tok_Private => + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Scan; -- past PRIVATE + TF_Semicolon; + exit; + + when Tok_Limited => + Scan; -- past LIMITED + + loop + if Token = Tok_Tagged then + Error_Msg_SC ("TAGGED must come before LIMITED"); + Scan; -- past TAGGED + + elsif Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before LIMITED"); + Scan; -- past ABSTRACT + + else + exit; + end if; + end loop; + + -- LIMITED RECORD or LIMITED NULL RECORD + + if Token = Tok_Record or else Token = Tok_Null then + if Ada_83 then + Error_Msg_SP + ("(Ada 83) limited record declaration not allowed!"); + end if; + + Typedef_Node := P_Record_Definition; + Set_Limited_Present (Typedef_Node, True); + + -- LIMITED PRIVATE is the only remaining possibility here + + else + Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); + Set_Limited_Present (Decl_Node, True); + T_Private; -- past PRIVATE (or complain if not there!) + end if; + + TF_Semicolon; + exit; + + -- Here we have an identifier after the IS, which is certainly + -- wrong and which might be one of several different mistakes. + + when Tok_Identifier => + + -- First case, if identifier is on same line, then probably we + -- have something like "type X is Integer .." and the best + -- diagnosis is a missing NEW. Note: the missing new message + -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. + + if not Token_Is_At_Start_Of_Line then + Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; + TF_Semicolon; + + -- If the identifier is at the start of the line, and is in the + -- same column as the type declaration itself then we consider + -- that we had a missing type definition on the previous line + + elsif Start_Column <= Type_Start_Col then + Error_Msg_AP ("type definition expected"); + Typedef_Node := Error; + + -- If the identifier is at the start of the line, and is in + -- a column to the right of the type declaration line, then we + -- may have something like: + + -- type x is + -- r : integer + + -- and the best diagnosis is a missing record keyword + + else + Typedef_Node := P_Record_Definition; + TF_Semicolon; + end if; + + exit; + + -- Anything else is an error + + when others => + if Bad_Spelling_Of (Tok_Access) + or else + Bad_Spelling_Of (Tok_Array) + or else + Bad_Spelling_Of (Tok_Delta) + or else + Bad_Spelling_Of (Tok_Digits) + or else + Bad_Spelling_Of (Tok_Limited) + or else + Bad_Spelling_Of (Tok_Private) + or else + Bad_Spelling_Of (Tok_Range) + or else + Bad_Spelling_Of (Tok_Record) + or else + Bad_Spelling_Of (Tok_Tagged) + then + null; + + else + Error_Msg_AP ("type definition expected"); + raise Error_Resync; + end if; + + end case; + end loop; + + -- For the private type declaration case, the private type declaration + -- node has been built, with the Tagged_Present and Limited_Present + -- flags set as needed, and Typedef_Node is left set to Empty. + + if No (Typedef_Node) then + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Decl_Node, Abstract_Present); + + -- For a private extension declaration, Typedef_Node contains the + -- N_Private_Extension_Declaration node, which we now complete. Note + -- that the private extension declaration, unlike a full type + -- declaration, does permit unknown discriminants. + + elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then + Decl_Node := Typedef_Node; + Set_Sloc (Decl_Node, Type_Loc); + Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + -- In the full type declaration case, Typedef_Node has the type + -- definition and here is where we build the full type declaration + -- node. This is also where we check for improper use of an unknown + -- discriminant part (not allowed for full type declaration). + + else + if Nkind (Typedef_Node) = N_Record_Definition + or else (Nkind (Typedef_Node) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Typedef_Node))) + then + Set_Abstract_Present (Typedef_Node, Abstract_Present); + + elsif Abstract_Present then + Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); + end if; + + Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); + Set_Type_Definition (Decl_Node, Typedef_Node); + + if Unknown_Dis then + Error_Msg + ("Full type declaration cannot have unknown discriminants", + Discr_Sloc); + end if; + end if; + + -- Remaining processing is common for all three cases + + Set_Defining_Identifier (Decl_Node, Ident_Node); + Set_Discriminant_Specifications (Decl_Node, Discr_List); + return Decl_Node; + + end P_Type_Declaration; + + ---------------------------------- + -- 3.2.1 Full Type Declaration -- + ---------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.2.1 Type Definition -- + ---------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------- + -- 3.2.2 Subtype Declaration -- + -------------------------------- + + -- SUBTYPE_DECLARATION ::= + -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; + + -- The caller has checked that the initial token is SUBTYPE + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Declaration return Node_Id is + Decl_Node : Node_Id; + + begin + Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); + Scan; -- past SUBTYPE + Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); + TF_Is; + + if Token = Tok_New then + Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); + Scan; -- past NEW + end if; + + Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); + TF_Semicolon; + return Decl_Node; + end P_Subtype_Declaration; + + ------------------------------- + -- 3.2.2 Subtype Indication -- + ------------------------------- + + -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Indication return Node_Id is + Type_Node : Node_Id; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Type_Node := P_Subtype_Mark; + return P_Subtype_Indication (Type_Node); + + else + -- Check for error of using record definition and treat it nicely, + -- otherwise things are really messed up, so resynchronize. + + if Token = Tok_Record then + Error_Msg_SC ("anonymous record definitions are not permitted"); + Discard_Junk_Node (P_Record_Definition); + return Error; + + else + Error_Msg_AP ("subtype indication expected"); + raise Error_Resync; + end if; + end if; + end P_Subtype_Indication; + + -- The following function is identical except that it is called with + -- the subtype mark already scanned out, and it scans out the constraint + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is + Indic_Node : Node_Id; + Constr_Node : Node_Id; + + begin + Constr_Node := P_Constraint_Opt; + + if No (Constr_Node) then + return Subtype_Mark; + else + Indic_Node := New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); + Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Constraint (Indic_Node, Constr_Node); + return Indic_Node; + end if; + + end P_Subtype_Indication; + + ------------------------- + -- 3.2.2 Subtype Mark -- + ------------------------- + + -- SUBTYPE_MARK ::= subtype_NAME; + + -- Note: The subtype mark which appears after an IN or NOT IN + -- operator is parsed by P_Range_Or_Subtype_Mark (3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Subtype_Mark return Node_Id is + begin + return P_Subtype_Mark_Resync; + + exception + when Error_Resync => + return Error; + end P_Subtype_Mark; + + -- This routine differs from P_Subtype_Mark in that it insists that an + -- identifier be present, and if it is not, it raises Error_Resync. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Resync return Node_Id is + Type_Node : Node_Id; + + begin + if Token = Tok_Access then + Error_Msg_SC ("anonymous access type definition not allowed here"); + Scan; -- past ACCESS + end if; + + if Token = Tok_Array then + Error_Msg_SC ("anonymous array definition not allowed here"); + Discard_Junk_Node (P_Array_Type_Definition); + return Empty; + + else + Type_Node := P_Qualified_Simple_Name_Resync; + + -- Check for a subtype mark attribute. The only valid possibilities + -- are 'CLASS and 'BASE. Anything else is a definite error. We may + -- as well catch it here. + + if Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Type_Node); + else + return Type_Node; + end if; + end if; + end P_Subtype_Mark_Resync; + + -- The following function is called to scan out a subtype mark attribute. + -- The caller has already scanned out the subtype mark, which is passed in + -- as the argument, and has checked that the current token is apostrophe. + + -- Only a special subclass of attributes, called type attributes + -- (see Snames package) are allowed in this syntactic position. + + -- Note: if the apostrophe is followed by other than an identifier, then + -- the input expression is returned unchanged, and the scan pointer is + -- left pointing to the apostrophe. + + -- Error recovery: can raise Error_Resync + + function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is + Attr_Node : Node_Id := Empty; + Scan_State : Saved_Scan_State; + Prefix : Node_Id; + + begin + Prefix := Check_Subtype_Mark (Type_Node); + + if Prefix = Error then + raise Error_Resync; + end if; + + -- Loop through attributes appearing (more than one can appear as for + -- for example in X'Base'Class). We are at an apostrophe on entry to + -- this loop, and it runs once for each attribute parsed, with + -- Prefix being the current possible prefix if it is an attribute. + + loop + Save_Scan_State (Scan_State); -- at Apostrophe + Scan; -- past apostrophe + + if Token /= Tok_Identifier then + Restore_Scan_State (Scan_State); -- to apostrophe + return Prefix; -- no attribute after all + + elsif not Is_Type_Attribute_Name (Token_Name) then + Error_Msg_N + ("attribute & may not be used in a subtype mark", Token_Node); + raise Error_Resync; + + else + Attr_Node := + Make_Attribute_Reference (Prev_Token_Ptr, + Prefix => Prefix, + Attribute_Name => Token_Name); + Delete_Node (Token_Node); + Scan; -- past type attribute identifier + end if; + + exit when Token /= Tok_Apostrophe; + Prefix := Attr_Node; + end loop; + + -- Fall through here after scanning type attribute + + return Attr_Node; + end P_Subtype_Mark_Attribute; + + ----------------------- + -- 3.2.2 Constraint -- + ----------------------- + + -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT + + -- SCALAR_CONSTRAINT ::= + -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT + + -- COMPOSITE_CONSTRAINT ::= + -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT + + -- If no constraint is present, this function returns Empty + + -- Error recovery: can raise Error_Resync + + function P_Constraint_Opt return Node_Id is + begin + if Token = Tok_Range + or else Bad_Spelling_Of (Tok_Range) + then + return P_Range_Constraint; + + elsif Token = Tok_Digits + or else Bad_Spelling_Of (Tok_Digits) + then + return P_Digits_Constraint; + + elsif Token = Tok_Delta + or else Bad_Spelling_Of (Tok_Delta) + then + return P_Delta_Constraint; + + elsif Token = Tok_Left_Paren then + return P_Index_Or_Discriminant_Constraint; + + elsif Token = Tok_In then + Ignore (Tok_In); + return P_Constraint_Opt; + + else + return Empty; + end if; + + end P_Constraint_Opt; + + ------------------------------ + -- 3.2.2 Scalar Constraint -- + ------------------------------ + + -- Parsed by P_Constraint_Opt (3.2.2) + + --------------------------------- + -- 3.2.2 Composite Constraint -- + --------------------------------- + + -- Parsed by P_Constraint_Opt (3.2.2) + + -------------------------------------------------------- + -- 3.3 Identifier Declarations (Also 7.4, 8.5, 11.1) -- + -------------------------------------------------------- + + -- This routine scans out a declaration starting with an identifier: + + -- OBJECT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [constant] [aliased] + -- SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + + -- NUMBER_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; + + -- OBJECT_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME; + + -- EXCEPTION_RENAMING_DECLARATION ::= + -- DEFINING_IDENTIFIER : exception renames exception_NAME; + + -- EXCEPTION_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : exception; + + -- Note that the ALIASED indication in an object declaration is + -- marked by a flag in the parent node. + + -- The caller has checked that the initial token is an identifier + + -- The value returned is a list of declarations, one for each identifier + -- in the list (as described in Sinfo, we always split up multiple + -- declarations into the equivalent sequence of single declarations + -- using the More_Ids and Prev_Ids flags to preserve the source). + + -- If the identifier turns out to be a probable statement rather than + -- an identifier, then the scan is left pointing to the identifier and + -- No_List is returned. + + -- Error recovery: can raise Error_Resync + + procedure P_Identifier_Declarations + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Decl_Node : Node_Id; + Type_Node : Node_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + List_OK : Boolean := True; + Ident : Nat; + Init_Expr : Node_Id; + Init_Loc : Source_Ptr; + Con_Loc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- Used to save identifiers in the identifier list. The upper bound + -- of 4096 is expected to be infinite in practice, and we do not even + -- bother to check if this upper bound is exceeded. + + Num_Idents : Nat := 1; + -- Number of identifiers stored in Idents + + procedure No_List; + -- This procedure is called in renames cases to make sure that we do + -- not have more than one identifier. If we do have more than one + -- then an error message is issued (and the declaration is split into + -- multiple declarations) + + function Token_Is_Renames return Boolean; + -- Checks if current token is RENAMES, and if so, scans past it and + -- returns True, otherwise returns False. Includes checking for some + -- common error cases. + + procedure No_List is + begin + if Num_Idents > 1 then + Error_Msg ("identifier list not allowed for RENAMES", + Sloc (Idents (2))); + end if; + + List_OK := False; + end No_List; + + function Token_Is_Renames return Boolean is + At_Colon : Saved_Scan_State; + + begin + if Token = Tok_Colon then + Save_Scan_State (At_Colon); + Scan; -- past colon + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Error_Msg_SP ("extra "":"" ignored"); + Scan; -- past RENAMES + return True; + else + Restore_Scan_State (At_Colon); + return False; + end if; + + else + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + Scan; -- past RENAMES + return True; + else + return False; + end if; + end if; + end Token_Is_Renames; + + -- Start of processing for P_Identifier_Declarations + + begin + Ident_Sloc := Token_Ptr; + Save_Scan_State (Scan_State); -- at first identifier + Idents (1) := P_Defining_Identifier; + + -- If we have a colon after the identifier, then we can assume that + -- this is in fact a valid identifier declaration and can steam ahead. + + if Token = Tok_Colon then + Scan; -- past colon + + -- If we have a comma, then scan out the list of identifiers + + elsif Token = Tok_Comma then + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + Save_Scan_State (Scan_State); -- at colon + T_Colon; + + -- If we have identifier followed by := then we assume that what is + -- really meant is an assignment statement. The assignment statement + -- is scanned out and added to the list of declarations. An exception + -- occurs if the := is followed by the keyword constant, in which case + -- we assume it was meant to be a colon. + + elsif Token = Tok_Colon_Equal then + Scan; -- past := + + if Token = Tok_Constant then + Error_Msg_SP ("colon expected"); + + else + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- If we have an IS keyword, then assume the TYPE keyword was missing + + elsif Token = Tok_Is then + Restore_Scan_State (Scan_State); + Append_To (Decls, P_Type_Declaration); + Done := False; + return; + + -- Otherwise we have an error situation + + else + Restore_Scan_State (Scan_State); + + -- First case is possible misuse of PROTECTED in Ada 83 mode. If + -- so, fix the keyword and return to scan the protected declaration. + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Identifier); + Check_95_Keyword (Tok_Protected, Tok_Type); + Check_95_Keyword (Tok_Protected, Tok_Body); + + if Token = Tok_Protected then + Done := False; + return; + end if; + + -- Check misspelling possibilities. If so, correct the misspelling + -- and return to scan out the resulting declaration. + + elsif Bad_Spelling_Of (Tok_Function) + or else Bad_Spelling_Of (Tok_Procedure) + or else Bad_Spelling_Of (Tok_Package) + or else Bad_Spelling_Of (Tok_Pragma) + or else Bad_Spelling_Of (Tok_Protected) + or else Bad_Spelling_Of (Tok_Generic) + or else Bad_Spelling_Of (Tok_Subtype) + or else Bad_Spelling_Of (Tok_Type) + or else Bad_Spelling_Of (Tok_Task) + or else Bad_Spelling_Of (Tok_Use) + or else Bad_Spelling_Of (Tok_For) + then + Done := False; + return; + + -- Otherwise we definitely have an ordinary identifier with a junk + -- token after it. Just complain that we expect a declaration, and + -- skip to a semicolon + + else + Set_Declaration_Expected; + Resync_Past_Semicolon; + Done := False; + return; + end if; + end if; + + -- Come here with an identifier list and colon scanned out. We now + -- build the nodes for the declarative items. One node is built for + -- each identifier in the list, with the type information being + -- repeated by rescanning the appropriate section of source. + + -- First an error check, if we have two identifiers in a row, a likely + -- possibility is that the first of the identifiers is an incorrectly + -- spelled keyword. + + if Token = Tok_Identifier then + declare + SS : Saved_Scan_State; + I2 : Boolean; + + begin + Save_Scan_State (SS); + Scan; -- past initial identifier + I2 := (Token = Tok_Identifier); + Restore_Scan_State (SS); + + if I2 + and then + (Bad_Spelling_Of (Tok_Access) or else + Bad_Spelling_Of (Tok_Aliased) or else + Bad_Spelling_Of (Tok_Constant)) + then + null; + end if; + end; + end if; + + -- Loop through identifiers + + Ident := 1; + Ident_Loop : loop + + -- Check for some cases of misused Ada 95 keywords + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + Check_95_Keyword (Tok_Aliased, Tok_Constant); + end if; + + -- Constant cases + + if Token = Tok_Constant then + Con_Loc := Token_Ptr; + Scan; -- past CONSTANT + + -- Number declaration, initialization required + + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); + Set_Expression (Decl_Node, Init_Expr); + + -- Constant object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Constant_Present (Decl_Node, True); + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Array); + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Error_Msg_SC ("ALIASED should be before CONSTANT"); + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + else + Set_Object_Definition (Decl_Node, P_Subtype_Indication); + end if; + + if Token = Tok_Renames then + Error_Msg + ("CONSTANT not permitted in renaming declaration", + Con_Loc); + Scan; -- Past renames + Discard_Junk_Node (P_Name); + end if; + end if; + + -- Exception cases + + elsif Token = Tok_Exception then + Scan; -- past EXCEPTION + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); + Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); + No_Constraint; + else + Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); + end if; + + -- Aliased case (note that an object definition is required) + + elsif Token = Tok_Aliased then + Scan; -- past ALIASED + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Aliased_Present (Decl_Node, True); + + if Token = Tok_Constant then + Scan; -- past CONSTANT + Set_Constant_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Set_Object_Definition + (Decl_Node, P_Array_Type_Definition); + else + Set_Object_Definition (Decl_Node, P_Subtype_Indication); + end if; + + -- Array case + + elsif Token = Tok_Array then + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition (Decl_Node, P_Array_Type_Definition); + + -- Subtype indication case + + else + Type_Node := P_Subtype_Mark; + + -- Object renaming declaration + + if Token_Is_Renames then + No_List; + Decl_Node := + New_Node (N_Object_Renaming_Declaration, Ident_Sloc); + Set_Subtype_Mark (Decl_Node, Type_Node); + Set_Name (Decl_Node, P_Name); + + -- Object declaration + + else + Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); + Set_Object_Definition + (Decl_Node, P_Subtype_Indication (Type_Node)); + + -- RENAMES at this point means that we had the combination of + -- a constraint on the Type_Node and renames, which is illegal + + if Token_Is_Renames then + Error_Msg_N + ("constraint not allowed in object renaming declaration", + Constraint (Object_Definition (Decl_Node))); + raise Error_Resync; + end if; + end if; + end if; + + -- Scan out initialization, allowed only for object declaration + + Init_Loc := Token_Ptr; + Init_Expr := Init_Expr_Opt; + + if Present (Init_Expr) then + if Nkind (Decl_Node) = N_Object_Declaration then + Set_Expression (Decl_Node, Init_Expr); + else + Error_Msg ("initialization not allowed here", Init_Loc); + end if; + end if; + + TF_Semicolon; + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + + if List_OK then + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + end if; + + Append (Decl_Node, Decls); + exit Ident_Loop when Ident = Num_Idents; + Restore_Scan_State (Scan_State); + T_Colon; + Ident := Ident + 1; + end loop Ident_Loop; + + Done := False; + + end P_Identifier_Declarations; + + ------------------------------- + -- 3.3.1 Object Declaration -- + ------------------------------- + + -- OBJECT DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- SUBTYPE_INDICATION [:= EXPRESSION]; + -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] + -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; + -- | SINGLE_TASK_DECLARATION + -- | SINGLE_PROTECTED_DECLARATION + + -- Cases starting with TASK are parsed by P_Task (9.1) + -- Cases starting with PROTECTED are parsed by P_Protected (9.4) + -- All other cases are parsed by P_Identifier_Declarations (3.3) + + ------------------------------------- + -- 3.3.1 Defining Identifier List -- + ------------------------------------- + + -- DEFINING_IDENTIFIER_LIST ::= + -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} + + -- Always parsed by the construct in which it appears. See special + -- section on "Handling of Defining Identifier Lists" in this unit. + + ------------------------------- + -- 3.3.2 Number Declaration -- + ------------------------------- + + -- Parsed by P_Identifier_Declarations (3.3) + + ------------------------------------------------------------------------- + -- 3.4 Derived Type Definition or Private Extension Declaration (7.3) -- + ------------------------------------------------------------------------- + + -- DERIVED_TYPE_DEFINITION ::= + -- [abstract] new parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART] + + -- PRIVATE_EXTENSION_DECLARATION ::= + -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is + -- [abstract] new ancestor_SUBTYPE_INDICATION with PRIVATE; + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- The caller has already scanned out the part up to the NEW, and Token + -- either contains Tok_New (or ought to, if it doesn't this procedure + -- will post an appropriate "NEW expected" message). + + -- Note: the caller is responsible for filling in the Sloc field of + -- the returned node in the private extension declaration case as + -- well as the stuff relating to the discriminant part. + + -- Error recovery: can raise Error_Resync; + + function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is + Typedef_Node : Node_Id; + Typedecl_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); + T_New; + + if Token = Tok_Abstract then + Error_Msg_SC ("ABSTRACT must come before NEW, not after"); + Scan; + end if; + + Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication); + + -- Deal with record extension, note that we assume that a WITH is + -- missing in the case of "type X is new Y record ..." or in the + -- case of "type X is new Y null record". + + if Token = Tok_With + or else Token = Tok_Record + or else Token = Tok_Null + then + T_With; -- past WITH or give error message + + if Token = Tok_Limited then + Error_Msg_SC + ("LIMITED keyword not allowed in private extension"); + Scan; -- ignore LIMITED + end if; + + -- Private extension declaration + + if Token = Tok_Private then + Scan; -- past PRIVATE + + -- Throw away the type definition node and build the type + -- declaration node. Note the caller must set the Sloc, + -- Discriminant_Specifications, Unknown_Discriminants_Present, + -- and Defined_Identifier fields in the returned node. + + Typedecl_Node := + Make_Private_Extension_Declaration (No_Location, + Defining_Identifier => Empty, + Subtype_Indication => Subtype_Indication (Typedef_Node), + Abstract_Present => Abstract_Present (Typedef_Node)); + + Delete_Node (Typedef_Node); + return Typedecl_Node; + + -- Derived type definition with record extension part + + else + Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); + return Typedef_Node; + end if; + + -- Derived type definition with no record extension part + + else + return Typedef_Node; + end if; + end P_Derived_Type_Def_Or_Private_Ext_Decl; + + --------------------------- + -- 3.5 Range Constraint -- + --------------------------- + + -- RANGE_CONSTRAINT ::= range RANGE + + -- The caller has checked that the initial token is RANGE + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Constraint return Node_Id is + Range_Node : Node_Id; + + begin + Range_Node := New_Node (N_Range_Constraint, Token_Ptr); + Scan; -- past RANGE + Set_Range_Expression (Range_Node, P_Range); + return Range_Node; + end P_Range_Constraint; + + ---------------- + -- 3.5 Range -- + ---------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- Note: the range that appears in a membership test is parsed by + -- P_Range_Or_Subtype_Mark (3.5). + + -- Error recovery: cannot raise Error_Resync + + function P_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Dot_Dot then + 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); + return Range_Node; + + -- Anything else is an error + + else + T_Dot_Dot; -- force missing .. message + return Error; + end if; + end P_Range; + + ---------------------------------- + -- 3.5 P_Range_Or_Subtype_Mark -- + ---------------------------------- + + -- RANGE ::= + -- RANGE_ATTRIBUTE_REFERENCE + -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION + + -- This routine scans out the range or subtype mark that forms the right + -- operand of a membership test. + + -- Note: as documented in the Sinfo interface, although the syntax only + -- allows a subtype mark, we in fact allow any simple expression to be + -- returned from this routine. The semantics is responsible for issuing + -- an appropriate message complaining if the argument is not a name. + -- This simplifies the coding and error recovery processing in the + -- parser, and in any case it is preferable not to consider this a + -- syntax error and to continue with the semantic analysis. + + -- Error recovery: cannot raise Error_Resync + + function P_Range_Or_Subtype_Mark return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + -- 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 .. + Set_High_Bound (Range_Node, P_Simple_Expression); + return Range_Node; + + -- Case of subtype mark (optionally qualified simple name or an + -- attribute whose prefix is an optionally qualifed simple name) + + elsif Expr_Form = EF_Simple_Name + or else Nkind (Expr_Node) = N_Attribute_Reference + then + -- Check for error of range constraint after a subtype mark + + if Token = Tok_Range then + Error_Msg_SC + ("range constraint not allowed in membership test"); + Scan; -- past RANGE + raise Error_Resync; + + -- Check for error of DIGITS or DELTA after a subtype mark + + elsif Token = Tok_Digits or else Token = Tok_Delta then + Error_Msg_SC + ("accuracy definition not allowed in membership test"); + Scan; -- past DIGITS or DELTA + raise Error_Resync; + + elsif Token = Tok_Apostrophe then + return P_Subtype_Mark_Attribute (Expr_Node); + + else + return Expr_Node; + end if; + + -- At this stage, we have some junk following the expression. We + -- really can't tell what is wrong, might be a missing semicolon, + -- or a missing THEN, or whatever. Our caller will figure it out! + + else + return Expr_Node; + end if; + end P_Range_Or_Subtype_Mark; + + ---------------------------------------- + -- 3.5.1 Enumeration Type Definition -- + ---------------------------------------- + + -- ENUMERATION_TYPE_DEFINITION ::= + -- (ENUMERATION_LITERAL_SPECIFICATION + -- {, ENUMERATION_LITERAL_SPECIFICATION}) + + -- The caller has already scanned out the TYPE keyword + + -- Error recovery: can raise Error_Resync; + + function P_Enumeration_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); + Set_Literals (Typedef_Node, New_List); + + T_Left_Paren; + + loop + Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); + exit when not Comma_Present; + end loop; + + T_Right_Paren; + return Typedef_Node; + end P_Enumeration_Type_Definition; + + ---------------------------------------------- + -- 3.5.1 Enumeration Literal Specification -- + ---------------------------------------------- + + -- ENUMERATION_LITERAL_SPECIFICATION ::= + -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL + + -- Error recovery: can raise Error_Resync + + function P_Enumeration_Literal_Specification return Node_Id is + begin + if Token = Tok_Char_Literal then + return P_Defining_Character_Literal; + else + return P_Defining_Identifier; + end if; + end P_Enumeration_Literal_Specification; + + --------------------------------------- + -- 3.5.1 Defining_Character_Literal -- + --------------------------------------- + + -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL + + -- Error recovery: cannot raise Error_Resync + + -- The caller has checked that the current token is a character literal + + function P_Defining_Character_Literal return Node_Id is + Literal_Node : Node_Id; + + begin + Literal_Node := Token_Node; + Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); + Scan; -- past character literal + return Literal_Node; + end P_Defining_Character_Literal; + + ------------------------------------ + -- 3.5.4 Integer Type Definition -- + ------------------------------------ + + -- Parsed by P_Type_Declaration (3.2.1) + + ------------------------------------------- + -- 3.5.4 Signed Integer Type Definition -- + ------------------------------------------- + + -- SIGNED_INTEGER_TYPE_DEFINITION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Normally the initial token on entry is RANGE, but in some + -- error conditions, the range token was missing and control is + -- passed with Token pointing to first token of the first expression. + + -- Error recovery: cannot raise Error_Resync + + function P_Signed_Integer_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); + + if Token = Tok_Range then + Scan; -- past RANGE + end if; + + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Typedef_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Typedef_Node, Expr_Node); + return Typedef_Node; + end P_Signed_Integer_Type_Definition; + + ------------------------------------ + -- 3.5.4 Modular Type Definition -- + ------------------------------------ + + -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION + + -- The caller has checked that the initial token is MOD + + -- Error recovery: cannot raise Error_Resync + + function P_Modular_Type_Definition return Node_Id is + Typedef_Node : Node_Id; + + begin + if Ada_83 then + Error_Msg_SC ("(Ada 83): modular types not allowed"); + end if; + + Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); + Scan; -- past MOD + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + + -- Handle mod L..R cleanly + + if Token = Tok_Dot_Dot then + Error_Msg_SC ("range not allowed for modular type"); + Scan; -- past .. + Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); + end if; + + return Typedef_Node; + end P_Modular_Type_Definition; + + --------------------------------- + -- 3.5.6 Real Type Definition -- + --------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + -------------------------------------- + -- 3.5.7 Floating Point Definition -- + -------------------------------------- + + -- FLOATING_POINT_DEFINITION ::= + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + -- Error recovery: cannot raise Error_Resync + + function P_Floating_Point_Definition return Node_Id is + Digits_Loc : constant Source_Ptr := Token_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + + -- Handle decimal fixed-point defn with DIGITS/DELTA in wrong order + + if Token = Tok_Delta then + Error_Msg_SC ("DELTA must come before DIGITS"); + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Digits_Loc); + Scan; -- past DELTA + Set_Delta_Expression (Def_Node, P_Expression_No_Right_Paren); + + -- OK floating-point definition + + else + Def_Node := New_Node (N_Floating_Point_Definition, Digits_Loc); + end if; + + Set_Digits_Expression (Def_Node, Expr_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Floating_Point_Definition; + + ------------------------------------- + -- 3.5.7 Real Range Specification -- + ------------------------------------- + + -- REAL_RANGE_SPECIFICATION ::= + -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION + + -- Error recovery: cannot raise Error_Resync + + function P_Real_Range_Specification_Opt return Node_Id is + Specification_Node : Node_Id; + Expr_Node : Node_Id; + + begin + if Token = Tok_Range then + Specification_Node := + New_Node (N_Real_Range_Specification, Token_Ptr); + Scan; -- past RANGE + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_Low_Bound (Specification_Node, Expr_Node); + T_Dot_Dot; + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Specification_Node, Expr_Node); + return Specification_Node; + else + return Empty; + end if; + end P_Real_Range_Specification_Opt; + + ----------------------------------- + -- 3.5.9 Fixed Point Definition -- + ----------------------------------- + + -- FIXED_POINT_DEFINITION ::= + -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION + + -- ORDINARY_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION + + -- DECIMAL_FIXED_POINT_DEFINITION ::= + -- delta static_EXPRESSION + -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Fixed_Point_Definition return Node_Id is + Delta_Node : Node_Id; + Delta_Loc : Source_Ptr; + Def_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Delta_Loc := Token_Ptr; + Scan; -- past DELTA + Delta_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Delta_Node); + + if Token = Tok_Digits then + if Ada_83 then + Error_Msg_SC ("(Ada 83) decimal fixed type not allowed!"); + end if; + + Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Def_Node, Expr_Node); + + else + Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); + + -- Range is required in ordinary fixed point case + + if Token /= Tok_Range then + Error_Msg_AP ("range must be given for fixed-point type"); + T_Range; + end if; + end if; + + Set_Delta_Expression (Def_Node, Delta_Node); + Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); + return Def_Node; + end P_Fixed_Point_Definition; + + -------------------------------------------- + -- 3.5.9 Ordinary Fixed Point Definition -- + -------------------------------------------- + + -- Parsed by P_Fixed_Point_Definition (3.5.9) + + ------------------------------------------- + -- 3.5.9 Decimal Fixed Point Definition -- + ------------------------------------------- + + -- Parsed by P_Decimal_Point_Definition (3.5.9) + + ------------------------------ + -- 3.5.9 Digits Constraint -- + ------------------------------ + + -- DIGITS_CONSTRAINT ::= + -- digits static_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DIGITS + + function P_Digits_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); + Scan; -- past DIGITS + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Digits_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Digits_Constraint; + + ----------------------------- + -- 3.5.9 Delta Constraint -- + ----------------------------- + + -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] + + -- Note: this is an obsolescent feature in Ada 95 (I.3) + + -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION + + -- The caller has checked that the initial token is DELTA + + -- Error recovery: cannot raise Error_Resync + + function P_Delta_Constraint return Node_Id is + Constraint_Node : Node_Id; + Expr_Node : Node_Id; + + begin + Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); + Scan; -- past DELTA + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Set_Delta_Expression (Constraint_Node, Expr_Node); + + if Token = Tok_Range then + Set_Range_Constraint (Constraint_Node, P_Range_Constraint); + end if; + + return Constraint_Node; + end P_Delta_Constraint; + + -------------------------------- + -- 3.6 Array Type Definition -- + -------------------------------- + + -- ARRAY_TYPE_DEFINITION ::= + -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION + + -- UNCONSTRAINED_ARRAY_DEFINITION ::= + -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> + + -- CONSTRAINED_ARRAY_DEFINITION ::= + -- array (DISCRETE_SUBTYPE_DEFINITION {, DISCRETE_SUBTYPE_DEFINITION}) of + -- COMPONENT_DEFINITION + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- DISCRETE_SUBTYPE_INDICATION | RANGE + + -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION + + -- The caller has checked that the initial token is ARRAY + + -- Error recovery: can raise Error_Resync + + function P_Array_Type_Definition return Node_Id is + Array_Loc : Source_Ptr; + Def_Node : Node_Id; + Subs_List : List_Id; + Scan_State : Saved_Scan_State; + + begin + Array_Loc := Token_Ptr; + Scan; -- past ARRAY + Subs_List := New_List; + T_Left_Paren; + + -- It's quite tricky to disentangle these two possibilities, so we do + -- a prescan to determine which case we have and then reset the scan. + -- The prescan skips past possible subtype mark tokens. + + Save_Scan_State (Scan_State); -- just after paren + + while Token in Token_Class_Desig or else + Token = Tok_Dot or else + Token = Tok_Apostrophe -- because of 'BASE, 'CLASS + loop + Scan; + end loop; + + -- If we end up on RANGE <> then we have the unconstrained case. We + -- will also allow the RANGE to be omitted, just to improve error + -- handling for a case like array (integer <>) of integer; + + Scan; -- past possible RANGE or <> + + if (Prev_Token = Tok_Range and then Token = Tok_Box) or else + Prev_Token = Tok_Box + then + Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first subtype mark + + loop + Append (P_Subtype_Mark_Resync, Subs_List); + T_Range; + T_Box; + exit when Token = Tok_Right_Paren or else Token = Tok_Of; + T_Comma; + end loop; + + Set_Subtype_Marks (Def_Node, Subs_List); + + else + Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); + Restore_Scan_State (Scan_State); -- to first discrete range + + loop + Append (P_Discrete_Subtype_Definition, Subs_List); + exit when not Comma_Present; + end loop; + + Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); + end if; + + T_Right_Paren; + T_Of; + + if Token = Tok_Aliased then + Set_Aliased_Present (Def_Node, True); + Scan; -- past ALIASED + end if; + + Set_Subtype_Indication (Def_Node, P_Subtype_Indication); + return Def_Node; + end P_Array_Type_Definition; + + ----------------------------------------- + -- 3.6 Unconstrained Array Definition -- + ----------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + --------------------------------------- + -- 3.6 Constrained Array Definition -- + --------------------------------------- + + -- Parsed by P_Array_Type_Definition (3.6) + + -------------------------------------- + -- 3.6 Discrete Subtype Definition -- + -------------------------------------- + + -- DISCRETE_SUBTYPE_DEFINITION ::= + -- discrete_SUBTYPE_INDICATION | RANGE + + -- Note: the discrete subtype definition appearing in a constrained + -- array definition is parsed by P_Array_Type_Definition (3.6) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Subtype_Definition return Node_Id is + begin + + -- The syntax of a discrete subtype definition is identical to that + -- of a discrete range, so we simply share the same parsing code. + + return P_Discrete_Range; + end P_Discrete_Subtype_Definition; + + ------------------------------- + -- 3.6 Component Definition -- + ------------------------------- + + -- For the array case, parsed by P_Array_Type_Definition (3.6) + -- For the record case, parsed by P_Component_Declaration (3.8) + + ----------------------------- + -- 3.6.1 Index Constraint -- + ----------------------------- + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + --------------------------- + -- 3.6.1 Discrete Range -- + --------------------------- + + -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE + + -- The possible forms for a discrete range are: + + -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) + -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) + -- Range_Attribute (RANGE, 3.5) + -- Simple_Expression .. Simple_Expression (RANGE, 3.5) + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Range return Node_Id is + Expr_Node : Node_Id; + Range_Node : Node_Id; + + begin + Expr_Node := P_Simple_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + return Expr_Node; + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("range must be preceded by subtype mark"); + end if; + + return P_Subtype_Indication (Expr_Node); + + -- Check Expression .. Expression case + + elsif Token = Tok_Dot_Dot then + 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); + return Range_Node; + + -- Otherwise we must have a subtype mark + + elsif Expr_Form = EF_Simple_Name then + return Expr_Node; + + -- If incorrect, complain that we expect .. + + else + T_Dot_Dot; + return Expr_Node; + end if; + end P_Discrete_Range; + + ---------------------------- + -- 3.7 Discriminant Part -- + ---------------------------- + + -- DISCRIMINANT_PART ::= + -- UNKNOWN_DISCRIMINANT_PART + -- | KNOWN_DISCRIMINANT_PART + + -- A discriminant part is parsed by P_Known_Discriminant_Part_Opt (3.7) + -- or P_Unknown_Discriminant_Part (3.7), since we know which we want. + + ------------------------------------ + -- 3.7 Unknown Discriminant Part -- + ------------------------------------ + + -- UNKNOWN_DISCRIMINANT_PART ::= (<>) + + -- If no unknown discriminant part is present, then False is returned, + -- otherwise the unknown discriminant is scanned out and True is returned. + + -- Error recovery: cannot raise Error_Resync + + function P_Unknown_Discriminant_Part_Opt return Boolean is + Scan_State : Saved_Scan_State; + + begin + if Token /= Tok_Left_Paren then + return False; + + else + Save_Scan_State (Scan_State); + Scan; -- past the left paren + + if Token = Tok_Box then + + if Ada_83 then + Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); + end if; + + Scan; -- past the box + T_Right_Paren; -- must be followed by right paren + return True; + + else + Restore_Scan_State (Scan_State); + return False; + end if; + end if; + end P_Unknown_Discriminant_Part_Opt; + + ---------------------------------- + -- 3.7 Known Discriminant Part -- + ---------------------------------- + + -- KNOWN_DISCRIMINANT_PART ::= + -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) + + -- DISCRIMINANT_SPECIFICATION ::= + -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK + -- [:= DEFAULT_EXPRESSION] + -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION + -- [:= DEFAULT_EXPRESSION] + + -- If no known discriminant part is present, then No_List is returned + + -- Error recovery: cannot raise Error_Resync + + function P_Known_Discriminant_Part_Opt return List_Id is + Specification_Node : Node_Id; + Specification_List : List_Id; + Ident_Sloc : Source_Ptr; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token = Tok_Left_Paren then + Specification_List := New_List; + Scan; -- past ( + P_Pragmas_Misplaced; + + Specification_Loop : loop + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + Specification_Node := + New_Node (N_Discriminant_Specification, Ident_Sloc); + Set_Defining_Identifier (Specification_Node, Idents (Ident)); + + if Token = Tok_Access then + if Ada_83 then + Error_Msg_SC + ("(Ada 83) access discriminant not allowed!"); + end if; + + Set_Discriminant_Type + (Specification_Node, P_Access_Definition); + else + Set_Discriminant_Type + (Specification_Node, P_Subtype_Mark); + No_Constraint; + end if; + + Set_Expression + (Specification_Node, Init_Expr_Opt (True)); + + if Ident > 1 then + Set_Prev_Ids (Specification_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Specification_Node, True); + end if; + + Append (Specification_Node, Specification_List); + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + end loop Ident_Loop; + + exit Specification_Loop when Token /= Tok_Semicolon; + Scan; -- past ; + P_Pragmas_Misplaced; + end loop Specification_Loop; + + T_Right_Paren; + return Specification_List; + + else + return No_List; + end if; + end P_Known_Discriminant_Part_Opt; + + ------------------------------------- + -- 3.7 DIscriminant Specification -- + ------------------------------------- + + -- Parsed by P_Known_Discriminant_Part_Opt (3.7) + + ----------------------------- + -- 3.7 Default Expression -- + ----------------------------- + + -- Always parsed (simply as an Expression) by the parent construct + + ------------------------------------ + -- 3.7.1 Discriminant Constraint -- + ------------------------------------ + + -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) + + -------------------------------------------------------- + -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- + -------------------------------------------------------- + + -- DISCRIMINANT_CONSTRAINT ::= + -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine parses either an index or a discriminant constraint. As + -- is clear from the above grammar, it is often possible to clearly + -- determine which of the two possibilities we have, but there are + -- cases (those in which we have a series of expressions of the same + -- syntactic form as subtype indications), where we cannot tell. Since + -- this means that in any case the semantic phase has to distinguish + -- between the two, there is not much point in the parser trying to + -- distinguish even those cases where the difference is clear. In any + -- case, if we have a situation like: + + -- (A => 123, 235 .. 500) + + -- it is not clear which of the two items is the wrong one, better to + -- let the semantic phase give a clear message. Consequently, this + -- routine in general returns a list of items which can be either + -- discrete ranges or discriminant associations. + + -- The caller has checked that the initial token is a left paren + + -- Error recovery: can raise Error_Resync + + function P_Index_Or_Discriminant_Constraint return Node_Id is + Scan_State : Saved_Scan_State; + Constr_Node : Node_Id; + Constr_List : List_Id; + Expr_Node : Node_Id; + Result_Node : Node_Id; + + begin + Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); + Scan; -- past ( + Constr_List := New_List; + Set_Constraints (Result_Node, Constr_List); + + -- The two syntactic forms are a little mixed up, so what we are doing + -- here is looking at the first entry to determine which case we have + + -- A discriminant constraint is a list of discriminant associations, + -- which have one of the following possible forms: + + -- Expression + -- Id => Expression + -- Id | Id | .. | Id => Expression + + -- An index constraint is a list of discrete ranges which have one + -- of the following possible forms: + + -- Subtype_Mark + -- Subtype_Mark range Range + -- Range_Attribute + -- Simple_Expression .. Simple_Expression + + -- Loop through discriminants in list + + loop + -- Check cases of Id => Expression or Id | Id => Expression + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); -- at Id + Scan; -- past Id + + if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then + Restore_Scan_State (Scan_State); -- to Id + Append (P_Discriminant_Association, Constr_List); + goto Loop_Continue; + else + Restore_Scan_State (Scan_State); -- to Id + end if; + end if; + + -- Otherwise scan out an expression and see what we have got + + Expr_Node := P_Expression_Or_Range_Attribute; + + if Expr_Form = EF_Range_Attr then + Append (Expr_Node, Constr_List); + + elsif Token = Tok_Range then + if Expr_Form /= EF_Simple_Name then + Error_Msg_SC ("subtype mark required before RANGE"); + end if; + + Append (P_Subtype_Indication (Expr_Node), Constr_List); + goto Loop_Continue; + + -- Check Simple_Expression .. Simple_Expression case + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Constr_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Constr_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Constr_Node, Expr_Node); + Append (Constr_Node, Constr_List); + goto Loop_Continue; + + -- Case of an expression which could be either form + + else + Append (Expr_Node, Constr_List); + goto Loop_Continue; + end if; + + -- Here with a single entry scanned + + <<Loop_Continue>> + exit when not Comma_Present; + + end loop; + + T_Right_Paren; + return Result_Node; + + end P_Index_Or_Discriminant_Constraint; + + ------------------------------------- + -- 3.7.1 Discriminant Association -- + ------------------------------------- + + -- DISCRIMINANT_ASSOCIATION ::= + -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] + -- EXPRESSION + + -- This routine is used only when the name list is present and the caller + -- has already checked this (by scanning ahead and repositioning the + -- scan). + + -- Error_Recovery: cannot raise Error_Resync; + + function P_Discriminant_Association return Node_Id is + Discr_Node : Node_Id; + Names_List : List_Id; + Ident_Sloc : Source_Ptr; + + begin + Ident_Sloc := Token_Ptr; + Names_List := New_List; + + loop + Append (P_Identifier, Names_List); + exit when Token /= Tok_Vertical_Bar; + Scan; -- past | + end loop; + + Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); + Set_Selector_Names (Discr_Node, Names_List); + TF_Arrow; + Set_Expression (Discr_Node, P_Expression); + return Discr_Node; + end P_Discriminant_Association; + + --------------------------------- + -- 3.8 Record Type Definition -- + --------------------------------- + + -- RECORD_TYPE_DEFINITION ::= + -- [[abstract] tagged] [limited] RECORD_DEFINITION + + -- There is no node in the tree for a record type definition. Instead + -- a record definition node appears, with possible Abstract_Present, + -- Tagged_Present, and Limited_Present flags set appropriately. + + ---------------------------- + -- 3.8 Record Definition -- + ---------------------------- + + -- RECORD_DEFINITION ::= + -- record + -- COMPONENT_LIST + -- end record + -- | null record + + -- Note: in the case where a record definition node is used to represent + -- a record type definition, the caller sets the Tagged_Present and + -- Limited_Present flags in the resulting N_Record_Definition node as + -- required. + + -- Note that the RECORD token at the start may be missing in certain + -- error situations, so this function is expected to post the error + + -- Error recovery: can raise Error_Resync + + function P_Record_Definition return Node_Id is + Rec_Node : Node_Id; + + begin + Rec_Node := New_Node (N_Record_Definition, Token_Ptr); + + -- Null record case + + if Token = Tok_Null then + Scan; -- past NULL + T_Record; + Set_Null_Present (Rec_Node, True); + + -- Case starting with RECORD keyword. Build scope stack entry. For the + -- column, we use the first non-blank character on the line, to deal + -- with situations such as: + + -- type X is record + -- ... + -- end record; + + -- which is not official RM indentation, but is not uncommon usage + + else + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Record; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Labl := Error; + Scope.Table (Scope.Last).Junk := (Token /= Tok_Record); + + T_Record; + + Set_Component_List (Rec_Node, P_Component_List); + + loop + exit when Check_End; + Discard_Junk_Node (P_Component_List); + end loop; + end if; + + return Rec_Node; + end P_Record_Definition; + + ------------------------- + -- 3.8 Component List -- + ------------------------- + + -- COMPONENT_LIST ::= + -- COMPONENT_ITEM {COMPONENT_ITEM} + -- | {COMPONENT_ITEM} VARIANT_PART + -- | null; + + -- Error recovery: cannot raise Error_Resync + + function P_Component_List return Node_Id is + Component_List_Node : Node_Id; + Decls_List : List_Id; + Scan_State : Saved_Scan_State; + + begin + Component_List_Node := New_Node (N_Component_List, Token_Ptr); + Decls_List := New_List; + + if Token = Tok_Null then + Scan; -- past NULL + TF_Semicolon; + P_Pragmas_Opt (Decls_List); + Set_Null_Present (Component_List_Node, True); + return Component_List_Node; + + else + P_Pragmas_Opt (Decls_List); + + if Token /= Tok_Case then + Component_Scan_Loop : loop + P_Component_Items (Decls_List); + P_Pragmas_Opt (Decls_List); + + exit Component_Scan_Loop when Token = Tok_End + or else Token = Tok_Case + or else Token = Tok_When; + + -- We are done if we do not have an identifier. However, if + -- we have a misspelled reserved identifier that is in a column + -- to the right of the record definition, we will treat it as + -- an identifier. It turns out to be too dangerous in practice + -- to accept such a mis-spelled identifier which does not have + -- this additional clue that confirms the incorrect spelling. + + if Token /= Tok_Identifier then + if Start_Column > Scope.Table (Scope.Last).Ecol + and then Is_Reserved_Identifier + then + Save_Scan_State (Scan_State); -- at reserved id + Scan; -- possible reserved id + + if Token = Tok_Comma or else Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + + -- Note reserved identifier used as field name after + -- all because not followed by colon or comma + + else + Restore_Scan_State (Scan_State); + exit Component_Scan_Loop; + end if; + + -- Non-identifier that definitely was not reserved id + + else + exit Component_Scan_Loop; + end if; + end if; + end loop Component_Scan_Loop; + end if; + + if Token = Tok_Case then + Set_Variant_Part (Component_List_Node, P_Variant_Part); + + -- Check for junk after variant part + + if Token = Tok_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past identifier + + if Token = Tok_Colon then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("component may not follow variant part"); + Discard_Junk_Node (P_Component_List); + + elsif Token = Tok_Case then + Restore_Scan_State (Scan_State); + Error_Msg_SC ("only one variant part allowed in a record"); + Discard_Junk_Node (P_Component_List); + + else + Restore_Scan_State (Scan_State); + end if; + end if; + end if; + end if; + + Set_Component_Items (Component_List_Node, Decls_List); + return Component_List_Node; + + end P_Component_List; + + ------------------------- + -- 3.8 Component Item -- + ------------------------- + + -- COMPONENT_ITEM ::= COMPONENT_DECLARATION | REPRESENTATION_CLAUSE + + -- COMPONENT_DECLARATION ::= + -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION + -- [:= DEFAULT_EXPRESSION]; + + -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION + + -- Error recovery: cannot raise Error_Resync, if an error occurs, + -- the scan is positioned past the following semicolon. + + -- Note: we do not yet allow representation clauses to appear as component + -- items, do we need to add this capability sometime in the future ??? + + procedure P_Component_Items (Decls : List_Id) is + Decl_Node : Node_Id; + Scan_State : Saved_Scan_State; + Num_Idents : Nat; + Ident : Nat; + Ident_Sloc : Source_Ptr; + + Idents : array (Int range 1 .. 4096) of Entity_Id; + -- This array holds the list of defining identifiers. The upper bound + -- of 4096 is intended to be essentially infinite, and we do not even + -- bother to check for it being exceeded. + + begin + if Token /= Tok_Identifier then + Error_Msg_SC ("component declaration expected"); + Resync_Past_Semicolon; + return; + end if; + + Ident_Sloc := Token_Ptr; + Idents (1) := P_Defining_Identifier; + Num_Idents := 1; + + while Comma_Present loop + Num_Idents := Num_Idents + 1; + Idents (Num_Idents) := P_Defining_Identifier; + end loop; + + T_Colon; + + -- If there are multiple identifiers, we repeatedly scan the + -- type and initialization expression information by resetting + -- the scan pointer (so that we get completely separate trees + -- for each occurrence). + + if Num_Idents > 1 then + Save_Scan_State (Scan_State); + end if; + + -- Loop through defining identifiers in list + + Ident := 1; + Ident_Loop : loop + + -- The following block is present to catch Error_Resync + -- which causes the parse to be reset past the semicolon + + begin + Decl_Node := New_Node (N_Component_Declaration, Ident_Sloc); + Set_Defining_Identifier (Decl_Node, Idents (Ident)); + + if Token = Tok_Constant then + Error_Msg_SC ("constant components are not permitted"); + Scan; + end if; + + if Token_Name = Name_Aliased then + Check_95_Keyword (Tok_Aliased, Tok_Identifier); + end if; + + if Token = Tok_Aliased then + Scan; -- past ALIASED + Set_Aliased_Present (Decl_Node, True); + end if; + + if Token = Tok_Array then + Error_Msg_SC ("anonymous arrays not allowed as components"); + raise Error_Resync; + end if; + + Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); + Set_Expression (Decl_Node, Init_Expr_Opt); + + if Ident > 1 then + Set_Prev_Ids (Decl_Node, True); + end if; + + if Ident < Num_Idents then + Set_More_Ids (Decl_Node, True); + end if; + + Append (Decl_Node, Decls); + + exception + when Error_Resync => + if Token /= Tok_End then + Resync_Past_Semicolon; + end if; + end; + + exit Ident_Loop when Ident = Num_Idents; + Ident := Ident + 1; + Restore_Scan_State (Scan_State); + + end loop Ident_Loop; + + TF_Semicolon; + + end P_Component_Items; + + -------------------------------- + -- 3.8 Component Declaration -- + -------------------------------- + + -- Parsed by P_Component_Items (3.8) + + ------------------------- + -- 3.8.1 Variant Part -- + ------------------------- + + -- VARIANT_PART ::= + -- case discriminant_DIRECT_NAME is + -- VARIANT + -- {VARIANT} + -- end case; + + -- The caller has checked that the initial token is CASE + + -- Error recovery: cannot raise Error_Resync + + function P_Variant_Part return Node_Id is + Variant_Part_Node : Node_Id; + Variants_List : List_Id; + Case_Node : Node_Id; + Case_Sloc : Source_Ptr; + + begin + Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Case; + Scope.Table (Scope.Last).Sloc := Token_Ptr; + Scope.Table (Scope.Last).Ecol := Start_Column; + + Scan; -- past CASE + Case_Node := P_Expression; + Case_Sloc := Token_Ptr; + Set_Name (Variant_Part_Node, Case_Node); + + if Nkind (Case_Node) /= N_Identifier then + Set_Name (Variant_Part_Node, Error); + Error_Msg ("discriminant name expected", Sloc (Case_Node)); + end if; + + TF_Is; + Variants_List := New_List; + P_Pragmas_Opt (Variants_List); + + -- Test missing variant + + if Token = Tok_End then + Error_Msg_BC ("WHEN expected (must have at least one variant)"); + else + Append (P_Variant, Variants_List); + end if; + + -- Loop through variants, note that we allow if in place of when, + -- this error will be detected and handled in P_Variant. + + loop + P_Pragmas_Opt (Variants_List); + + if Token /= Tok_When + and then Token /= Tok_If + and then Token /= Tok_Others + then + exit when Check_End; + end if; + + Append (P_Variant, Variants_List); + end loop; + + Set_Variants (Variant_Part_Node, Variants_List); + return Variant_Part_Node; + + end P_Variant_Part; + + -------------------- + -- 3.8.1 Variant -- + -------------------- + + -- VARIANT ::= + -- when DISCRETE_CHOICE_LIST => + -- COMPONENT_LIST + + -- Error recovery: cannot raise Error_Resync + + -- The initial token on entry is either WHEN, IF or OTHERS + + function P_Variant return Node_Id is + Variant_Node : Node_Id; + + begin + -- Special check to recover nicely from use of IF in place of WHEN + + if Token = Tok_If then + T_When; + Scan; -- past IF + else + T_When; + end if; + + Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); + Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); + TF_Arrow; + Set_Component_List (Variant_Node, P_Component_List); + return Variant_Node; + end P_Variant; + + --------------------------------- + -- 3.8.1 Discrete Choice List -- + --------------------------------- + + -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} + + -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others + + -- Note: in Ada 83, the expression must be a simple expression + + -- Error recovery: cannot raise Error_Resync + + function P_Discrete_Choice_List return List_Id is + Choices : List_Id; + Expr_Node : Node_Id; + Choice_Node : Node_Id; + + begin + Choices := New_List; + + loop + if Token = Tok_Others then + Append (New_Node (N_Others_Choice, Token_Ptr), Choices); + Scan; -- past OTHERS + + else + begin + Expr_Node := No_Right_Paren (P_Expression_Or_Range_Attribute); + + if Token = Tok_Colon + and then Nkind (Expr_Node) = N_Identifier + then + Error_Msg_SP ("label not permitted in this context"); + Scan; -- past colon + + elsif Expr_Form = EF_Range_Attr then + Append (Expr_Node, Choices); + + elsif Token = Tok_Dot_Dot then + Check_Simple_Expression (Expr_Node); + Choice_Node := New_Node (N_Range, Token_Ptr); + Set_Low_Bound (Choice_Node, Expr_Node); + Scan; -- past .. + Expr_Node := P_Expression_No_Right_Paren; + Check_Simple_Expression (Expr_Node); + Set_High_Bound (Choice_Node, Expr_Node); + Append (Choice_Node, Choices); + + elsif Expr_Form = EF_Simple_Name then + if Token = Tok_Range then + Append (P_Subtype_Indication (Expr_Node), Choices); + + elsif Token in Token_Class_Consk then + Error_Msg_SC + ("the only constraint allowed here " & + "is a range constraint"); + Discard_Junk_Node (P_Constraint_Opt); + Append (Expr_Node, Choices); + + else + Append (Expr_Node, Choices); + end if; + + else + Check_Simple_Expression_In_Ada_83 (Expr_Node); + Append (Expr_Node, Choices); + end if; + + exception + when Error_Resync => + Resync_Choice; + return Error_List; + end; + end if; + + if Token = Tok_Comma then + Error_Msg_SC (""","" should be ""|"""); + else + exit when Token /= Tok_Vertical_Bar; + end if; + + Scan; -- past | or comma + end loop; + + return Choices; + end P_Discrete_Choice_List; + + ---------------------------- + -- 3.8.1 Discrete Choice -- + ---------------------------- + + -- Parsed by P_Discrete_Choice_List (3.8.1) + + ---------------------------------- + -- 3.9.1 Record Extension Part -- + ---------------------------------- + + -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION + + -- Parsed by P_Derived_Type_Def_Or_Private_Ext_Decl (3.4) + + ---------------------------------- + -- 3.10 Access Type Definition -- + ---------------------------------- + + -- ACCESS_TYPE_DEFINITION ::= + -- ACCESS_TO_OBJECT_DEFINITION + -- | ACCESS_TO_SUBPROGRAM_DEFINITION + + -- ACCESS_TO_OBJECT_DEFINITION ::= + -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION + + -- GENERAL_ACCESS_MODIFIER ::= all | constant + + -- ACCESS_TO_SUBPROGRAM_DEFINITION + -- access [protected] procedure PARAMETER_PROFILE + -- | access [protected] function PARAMETER_AND_RESULT_PROFILE + + -- PARAMETER_PROFILE ::= [FORMAL_PART] + + -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK + + -- The caller has checked that the initial token is ACCESS + + -- Error recovery: can raise Error_Resync + + function P_Access_Type_Definition return Node_Id is + Prot_Flag : Boolean; + Access_Loc : Source_Ptr; + Type_Def_Node : Node_Id; + + procedure Check_Junk_Subprogram_Name; + -- Used in access to subprogram definition cases to check for an + -- identifier or operator symbol that does not belong. + + procedure Check_Junk_Subprogram_Name is + Saved_State : Saved_Scan_State; + + begin + if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then + Save_Scan_State (Saved_State); + Scan; -- past possible junk subprogram name + + if Token = Tok_Left_Paren or else Token = Tok_Semicolon then + Error_Msg_SP ("unexpected subprogram name ignored"); + return; + + else + Restore_Scan_State (Saved_State); + end if; + end if; + end Check_Junk_Subprogram_Name; + + -- Start of processing for P_Access_Type_Definition + + begin + Access_Loc := Token_Ptr; + Scan; -- past ACCESS + + if Token_Name = Name_Protected then + Check_95_Keyword (Tok_Protected, Tok_Procedure); + Check_95_Keyword (Tok_Protected, Tok_Function); + end if; + + Prot_Flag := (Token = Tok_Protected); + + if Prot_Flag then + Scan; -- past PROTECTED + if Token /= Tok_Procedure and then Token /= Tok_Function then + Error_Msg_SC ("FUNCTION or PROCEDURE expected"); + end if; + end if; + + if Token = Tok_Procedure then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access to procedure not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); + Scan; -- past PROCEDURE + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + + elsif Token = Tok_Function then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access to function not allowed!"); + end if; + + Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); + Scan; -- past FUNCTION + Check_Junk_Subprogram_Name; + Set_Parameter_Specifications (Type_Def_Node, P_Parameter_Profile); + Set_Protected_Present (Type_Def_Node, Prot_Flag); + TF_Return; + Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark); + No_Constraint; + + else + Type_Def_Node := + New_Node (N_Access_To_Object_Definition, Access_Loc); + + if Token = Tok_All or else Token = Tok_Constant then + if Ada_83 then + Error_Msg_SC ("(Ada 83) access modifier not allowed!"); + end if; + + if Token = Tok_All then + Set_All_Present (Type_Def_Node, True); + + else + Set_Constant_Present (Type_Def_Node, True); + end if; + + Scan; -- past ALL or CONSTANT + end if; + + Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication); + end if; + + return Type_Def_Node; + end P_Access_Type_Definition; + + --------------------------------------- + -- 3.10 Access To Object Definition -- + --------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------------- + -- 3.10 General Access Modifier -- + ----------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ------------------------------------------- + -- 3.10 Access To Subprogram Definition -- + ------------------------------------------- + + -- Parsed by P_Access_Type_Definition (3.10) + + ----------------------------- + -- 3.10 Access Definition -- + ----------------------------- + + -- ACCESS_DEFINITION ::= access SUBTYPE_MARK + + -- The caller has checked that the initial token is ACCESS + + -- Error recovery: cannot raise Error_Resync + + function P_Access_Definition return Node_Id is + Def_Node : Node_Id; + + begin + Def_Node := New_Node (N_Access_Definition, Token_Ptr); + Scan; -- past ACCESS + Set_Subtype_Mark (Def_Node, P_Subtype_Mark); + No_Constraint; + return Def_Node; + end P_Access_Definition; + + ----------------------------------------- + -- 3.10.1 Incomplete Type Declaration -- + ----------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------- + -- 3.11 Declarative Part -- + ---------------------------- + + -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} + + -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items + -- handles errors, and returns cleanly after an error has occurred) + + function P_Declarative_Part return List_Id is + Decls : List_Id; + Done : Boolean; + + begin + -- Indicate no bad declarations detected yet. This will be reset by + -- P_Declarative_Items if a bad declaration is discovered. + + Missing_Begin_Msg := No_Error_Msg; + + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + Decls := New_List; + + -- Loop to scan out the declarations + + loop + P_Declarative_Items (Decls, Done, In_Spec => False); + exit when Done; + end loop; + + -- Get rid of active SIS entry which is left set only if we scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a missing body case). + + SIS_Entry_Active := False; + return Decls; + end P_Declarative_Part; + + ---------------------------- + -- 3.11 Declarative Item -- + ---------------------------- + + -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY + + -- Can return Error if a junk declaration is found, or Empty if no + -- declaration is found (i.e. a token ending declarations, such as + -- BEGIN or END is encountered). + + -- Error recovery: cannot raise Error_Resync. If an error resync occurs, + -- then the scan is set past the next semicolon and Error is returned. + + procedure P_Declarative_Items + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + Scan_State : Saved_Scan_State; + + begin + if Style_Check then Style.Check_Indentation; end if; + + case Token is + + when Tok_Function => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_For => + Check_Bad_Layout; + + -- Check for loop (premature statement) + + Save_Scan_State (Scan_State); + Scan; -- past FOR + + if Token = Tok_Identifier then + Scan; -- past identifier + + if Token = Tok_In then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + end if; + + -- Not a loop, so must be rep clause + + Restore_Scan_State (Scan_State); + Append (P_Representation_Clause, Decls); + Done := False; + + when Tok_Generic => + Check_Bad_Layout; + Append (P_Generic, Decls); + Done := False; + + when Tok_Identifier => + Check_Bad_Layout; + P_Identifier_Declarations (Decls, Done, In_Spec); + + when Tok_Package => + Check_Bad_Layout; + Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_Pragma => + Append (P_Pragma, Decls); + Done := False; + + when Tok_Procedure => + Check_Bad_Layout; + Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); + Done := False; + + when Tok_Protected => + Check_Bad_Layout; + Scan; -- past PROTECTED + Append (P_Protected, Decls); + Done := False; + + when Tok_Subtype => + Check_Bad_Layout; + Append (P_Subtype_Declaration, Decls); + Done := False; + + when Tok_Task => + Check_Bad_Layout; + Scan; -- past TASK + Append (P_Task, Decls); + Done := False; + + when Tok_Type => + Check_Bad_Layout; + Append (P_Type_Declaration, Decls); + Done := False; + + when Tok_Use => + Check_Bad_Layout; + Append (P_Use_Clause, Decls); + Done := False; + + when Tok_With => + Check_Bad_Layout; + Error_Msg_SC ("WITH can only appear in context clause"); + raise Error_Resync; + + -- BEGIN terminates the scan of a sequence of declarations unless + -- there is a missing subprogram body, see section on handling + -- semicolon in place of IS. We only treat the begin as satisfying + -- the subprogram declaration if it falls in the expected column + -- or to its right. + + when Tok_Begin => + if SIS_Entry_Active and then Start_Column >= SIS_Ecol then + + -- Here we have the case where a BEGIN is encountered during + -- declarations in a declarative part, or at the outer level, + -- and there is a subprogram declaration outstanding for which + -- no body has been supplied. This is the case where we assume + -- that the semicolon in the subprogram declaration should + -- really have been is. The active SIS entry describes the + -- subprogram declaration. On return the declaration has been + -- modified to become a body. + + declare + Specification_Node : Node_Id; + Decl_Node : Node_Id; + Body_Node : Node_Id; + + begin + -- First issue the error message. If we had a missing + -- semicolon in the declaration, then change the message + -- to <missing "is"> + + if SIS_Missing_Semicolon_Message /= No_Error_Msg then + Change_Error_Text -- Replace: "missing "";"" " + (SIS_Missing_Semicolon_Message, "missing ""is"""); + + -- Otherwise we saved the semicolon position, so complain + + else + Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc); + end if; + + -- The next job is to fix up any declarations that occurred + -- between the procedure header and the BEGIN. These got + -- chained to the outer declarative region (immediately + -- after the procedure declaration) and they should be + -- chained to the subprogram itself, which is a body + -- rather than a spec. + + Specification_Node := Specification (SIS_Declaration_Node); + Change_Node (SIS_Declaration_Node, N_Subprogram_Body); + Body_Node := SIS_Declaration_Node; + Set_Specification (Body_Node, Specification_Node); + Set_Declarations (Body_Node, New_List); + + loop + Decl_Node := Remove_Next (Body_Node); + exit when Decl_Node = Empty; + Append (Decl_Node, Declarations (Body_Node)); + end loop; + + -- Now make the scope table entry for the Begin-End and + -- scan it out + + Push_Scope_Stack; + Scope.Table (Scope.Last).Sloc := SIS_Sloc; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := SIS_Ecol; + Scope.Table (Scope.Last).Labl := SIS_Labl; + Scope.Table (Scope.Last).Lreq := False; + SIS_Entry_Active := False; + Scan; -- past BEGIN + Set_Handled_Statement_Sequence (Body_Node, + P_Handled_Sequence_Of_Statements); + End_Statements (Handled_Statement_Sequence (Body_Node)); + end; + + Done := False; + + else + Done := True; + end if; + + -- Normally an END terminates the scan for basic declarative + -- items. The one exception is END RECORD, which is probably + -- left over from some other junk. + + when Tok_End => + Save_Scan_State (Scan_State); -- at END + Scan; -- past END + + if Token = Tok_Record then + Error_Msg_SP ("no RECORD for this `end record`!"); + Scan; -- past RECORD + TF_Semicolon; + + else + Restore_Scan_State (Scan_State); -- to END + Done := True; + end if; + + -- The following tokens which can only be the start of a statement + -- are considered to end a declarative part (i.e. we have a missing + -- BEGIN situation). We are fairly conservative in making this + -- judgment, because it is a real mess to go into statement mode + -- prematurely in reponse to a junk declaration. + + when Tok_Abort | + Tok_Accept | + Tok_Declare | + Tok_Delay | + Tok_Exit | + Tok_Goto | + Tok_If | + Tok_Loop | + Tok_Null | + Tok_Requeue | + Tok_Select | + Tok_While => + + -- But before we decide that it's a statement, let's check for + -- a reserved word misused as an identifier. + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + -- If reserved identifier not followed by colon or comma, then + -- this is most likely an assignment statement to the bad id. + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + + -- Otherwise we have a declaration of the bad id + + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + -- If not reserved identifier, then it's definitely a statement + + else + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + end if; + + -- The token RETURN may well also signal a missing BEGIN situation, + -- however, we never let it end the declarative part, because it may + -- also be part of a half-baked function declaration. + + when Tok_Return => + Error_Msg_SC ("misplaced RETURN statement"); + raise Error_Resync; + + -- PRIVATE definitely terminates the declarations in a spec, + -- and is an error in a body. + + when Tok_Private => + if In_Spec then + Done := True; + else + Error_Msg_SC ("PRIVATE not allowed in body"); + Scan; -- past PRIVATE + end if; + + -- An end of file definitely terminates the declarations! + + when Tok_EOF => + Done := True; + + -- The remaining tokens do not end the scan, but cannot start a + -- valid declaration, so we signal an error and resynchronize. + -- But first check for misuse of a reserved identifier. + + when others => + + -- Here we check for a reserved identifier + + if Is_Reserved_Identifier then + Save_Scan_State (Scan_State); + Scan; -- past the token + + if Token /= Tok_Colon and then Token /= Tok_Comma then + Restore_Scan_State (Scan_State); + Set_Declaration_Expected; + raise Error_Resync; + else + Restore_Scan_State (Scan_State); + Scan_Reserved_Identifier (Force_Msg => True); + Check_Bad_Layout; + P_Identifier_Declarations (Decls, Done, In_Spec); + end if; + + else + Set_Declaration_Expected; + raise Error_Resync; + end if; + end case; + + -- To resynchronize after an error, we scan to the next semicolon and + -- return with Done = False, indicating that there may still be more + -- valid declarations to come. + + exception + when Error_Resync => + Resync_Past_Semicolon; + Done := False; + + end P_Declarative_Items; + + ---------------------------------- + -- 3.11 Basic Declarative Item -- + ---------------------------------- + + -- BASIC_DECLARATIVE_ITEM ::= + -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE + + -- Scan zero or more basic declarative items + + -- Error recovery: cannot raise Error_Resync. If an error is detected, then + -- the scan pointer is repositioned past the next semicolon, and the scan + -- for declarative items continues. + + function P_Basic_Declarative_Items return List_Id is + Decl : Node_Id; + Decls : List_Id; + Kind : Node_Kind; + Done : Boolean; + + begin + -- Get rid of active SIS entry from outer scope. This means we will + -- miss some nested cases, but it doesn't seem worth the effort. See + -- discussion in Par for further details + + SIS_Entry_Active := False; + + -- Loop to scan out declarations + + Decls := New_List; + + loop + P_Declarative_Items (Decls, Done, In_Spec => True); + exit when Done; + end loop; + + -- Get rid of active SIS entry. This is set only if we have scanned a + -- procedure declaration and have not found the body. We could give + -- an error message, but that really would be usurping the role of + -- semantic analysis (this really is a case of a missing body). + + SIS_Entry_Active := False; + + -- Test for assorted illegal declarations not diagnosed elsewhere. + + Decl := First (Decls); + + while Present (Decl) loop + Kind := Nkind (Decl); + + -- Test for body scanned, not acceptable as basic decl item + + if Kind = N_Subprogram_Body or else + Kind = N_Package_Body or else + Kind = N_Task_Body or else + Kind = N_Protected_Body + then + Error_Msg + ("proper body not allowed in package spec", Sloc (Decl)); + + -- Test for body stub scanned, not acceptable as basic decl item + + elsif Kind in N_Body_Stub then + Error_Msg + ("body stub not allowed in package spec", Sloc (Decl)); + + elsif Kind = N_Assignment_Statement then + Error_Msg + ("assignment statement not allowed in package spec", + Sloc (Decl)); + end if; + + Next (Decl); + end loop; + + return Decls; + end P_Basic_Declarative_Items; + + ---------------- + -- 3.11 Body -- + ---------------- + + -- For proper body, see below + -- For body stub, see 10.1.3 + + ----------------------- + -- 3.11 Proper Body -- + ----------------------- + + -- Subprogram body is parsed by P_Subprogram (6.1) + -- Package body is parsed by P_Package (7.1) + -- Task body is parsed by P_Task (9.1) + -- Protected body is parsed by P_Protected (9.4) + + ------------------------------ + -- Set_Declaration_Expected -- + ------------------------------ + + procedure Set_Declaration_Expected is + begin + Error_Msg_SC ("declaration expected"); + + if Missing_Begin_Msg = No_Error_Msg then + Missing_Begin_Msg := Get_Msg_Id; + end if; + end Set_Declaration_Expected; + + ---------------------- + -- Skip_Declaration -- + ---------------------- + + procedure Skip_Declaration (S : List_Id) is + Dummy_Done : Boolean; + + begin + P_Declarative_Items (S, Dummy_Done, False); + end Skip_Declaration; + + ----------------------------------------- + -- Statement_When_Declaration_Expected -- + ----------------------------------------- + + procedure Statement_When_Declaration_Expected + (Decls : List_Id; + Done : out Boolean; + In_Spec : Boolean) + is + begin + -- Case of second occurrence of statement in one declaration sequence + + if Missing_Begin_Msg /= No_Error_Msg then + + -- In the procedure spec case, just ignore it, we only give one + -- message for the first occurrence, since otherwise we may get + -- horrible cascading if BODY was missing in the header line. + + if In_Spec then + null; + + -- In the declarative part case, take a second statement as a sure + -- sign that we really have a missing BEGIN, and end the declarative + -- part now. Note that the caller will fix up the first message to + -- say "missing BEGIN" so that's how the error will be signalled. + + else + Done := True; + return; + end if; + + -- Case of first occurrence of unexpected statement + + else + -- If we are in a package spec, then give message of statement + -- not allowed in package spec. This message never gets changed. + + if In_Spec then + Error_Msg_SC ("statement not allowed in package spec"); + + -- If in declarative part, then we give the message complaining + -- about finding a statement when a declaration is expected. This + -- gets changed to a complaint about a missing BEGIN if we later + -- find that no BEGIN is present. + + else + Error_Msg_SC ("statement not allowed in declarative part"); + end if; + + -- Capture message Id. This is used for two purposes, first to + -- stop multiple messages, see test above, and second, to allow + -- the replacement of the message in the declarative part case. + + Missing_Begin_Msg := Get_Msg_Id; + end if; + + -- In all cases except the case in which we decided to terminate the + -- declaration sequence on a second error, we scan out the statement + -- and append it to the list of declarations (note that the semantics + -- can handle statements in a declaration list so if we proceed to + -- call the semantic phase, all will be (reasonably) well! + + Append_List_To (Decls, P_Sequence_Of_Statements (SS_Unco)); + + -- Done is set to False, since we want to continue the scan of + -- declarations, hoping that this statement was a temporary glitch. + -- If we indeed are now in the statement part (i.e. this was a missing + -- BEGIN, then it's not terrible, we will simply keep calling this + -- procedure to process the statements one by one, and then finally + -- hit the missing BEGIN, which will clean up the error message. + + Done := False; + + end Statement_When_Declaration_Expected; + +end Ch3; |