Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / par-ch3.adb < prev next >

Wrap

Text File | 1996-09-28 | 113KB | 3,411 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.101 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- 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, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ 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; Msg_Id : in out Error_Msg_Id; 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. Msg_Id saves the Id of the first "declaration expected" -- message, since only one such message is generated per declarative part, -- and also, this message is changed to "BEGIN expected" if no BEGIN is -- subsequently encountered. procedure P_Identifier_Declarations (Decls : List_Id; Done : out Boolean; Msg_Id : in out Error_Msg_Id; 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; Msg_Id : in out Error_Msg_Id; 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. ------------------- -- 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 T_Colon_Equal; if P then return P_Expression; else return P_Expression_No_Right_Paren; end if; else return Empty; 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 := False; Abstract_Loc : Source_Ptr; 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; 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 else TF_Is; end if; if Token_Name = Name_Abstract then Check_95_Keyword (Tok_Abstract, Tok_Tagged); Check_95_Keyword (Tok_Abstract, Tok_New); end if; if Token = Tok_Abstract then Note_Feature (Abstract_Types, Token_Ptr); Abstract_Present := True; Abstract_Loc := Token_Ptr; Scan; -- past ABSTRACT if Token = Tok_Limited or else Token = Tok_Private or else Token = Tok_Record then Error_Msg_AP ("TAGGED expected"); end if; end if; 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; 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 case Token is when Tok_Range => Typedef_Node := P_Signed_Integer_Type_Definition; TF_Semicolon; when Tok_Mod => Typedef_Node := P_Modular_Type_Definition; TF_Semicolon; when Tok_New => Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; TF_Semicolon; when Tok_Array => Typedef_Node := P_Array_Type_Definition; TF_Semicolon; when Tok_Access => Typedef_Node := P_Access_Type_Definition; TF_Semicolon; when Tok_Left_Paren => Typedef_Node := P_Enumeration_Type_Definition; TF_Semicolon; when Tok_Digits => Typedef_Node := P_Floating_Point_Definition; TF_Semicolon; when Tok_Delta => Typedef_Node := P_Fixed_Point_Definition; TF_Semicolon; when Tok_Record => Typedef_Node := P_Record_Definition; TF_Semicolon; when Tok_Null => Typedef_Node := P_Record_Definition; TF_Semicolon; when Tok_Tagged => Note_Feature (Tagged_Types, Token_Ptr); Scan; -- past TAGGED if Token = Tok_Abstract then Error_Msg_SC ("ABSTRACT must come before TAGGED"); Note_Feature (Abstract_Types, Token_Ptr); 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; -- PRIVATE when Tok_Private => Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Scan; -- past PRIVATE TF_Semicolon; when Tok_Limited => Scan; -- past LIMITED loop if Token = Tok_Tagged then Error_Msg_SC ("TAGGED must comes before LIMITED"); Scan; -- past TAGGED elsif Token = Tok_Abstract then Error_Msg_SC ("ABSTRACT must comes 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 Note_Feature (Limited_Record_Types, Prev_Token_Ptr); 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; -- 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 that 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; -- Anything else is an error when others => Error_Msg_AP ("type definition expected"); raise Error_Resync; end case; -- 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; 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; return P_Subtype_Indication (Type_Node); 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, Token_Ptr); 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; Attr_Node : Node_Id; begin 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; 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 then return P_Range_Constraint; elsif Token = Tok_Digits then return P_Digits_Constraint; elsif Token = Tok_Delta then return P_Delta_Constraint; elsif Token = Tok_Left_Paren then return P_Index_Or_Discriminant_Constraint; 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; Msg_Id : in out Error_Msg_Id; 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; 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) 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; -- 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, Msg_Id, 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); 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 need a colon and plough on. else Scan; -- past identifier T_Colon; 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. -- Loop through identifiers Ident := 1; Ident_Loop : loop 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); -- Check for const in place of constant elsif Token_Name = Name_Const then Save_Scan_State (Scan_State); Scan; -- past const if Token = Tok_Identifier or else Token = Tok_Array then Restore_Scan_State (Scan_State); Error_Msg_SC ("Incorrect spelling of keyword CONSTANT"); Token := Tok_Constant; else Restore_Scan_State (Scan_State); end if; end if; -- Constant cases if Token = Tok_Constant then 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; end if; -- Exception cases elsif Token = Tok_Exception then Scan; -- past EXCEPTION if Token = Tok_Renames then Scan; -- past RENAMES 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 Note_Feature (Aliased_Objects, Token_Ptr); 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 = Tok_Renames then Scan; -- past RENAMES 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 = Tok_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_Expression; Check_Simple_Expression (Expr_Node); if 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; -- If no double dot, must be range attribute elsif Token = Tok_Apostrophe then return P_Range_Attribute_Reference (Expr_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 -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] -- This routine scans out the range or subtype mark that forms the right -- operand of a membership test. function P_Range_Or_Subtype_Mark return Node_Id is Expr_Node : Node_Id; Range_Node : Node_Id; begin Expr_Node := P_Simple_Expression; -- Simple_Expression .. Simple_Expression as range if Token = Tok_Dot_Dot then 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; -- If no double dot, could be range attribute elsif Token = Tok_Apostrophe then return P_Range_Attribute_Reference (Expr_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; -- For other cases (call, non-simple name, qualified expression), we -- assume that we have a missing .. (as reasonable an error as any!) else T_Dot_Dot; -- give .. expected message raise Error_Resync; 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 -- The caller has checked that the initial token is RANGE -- 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); Scan; -- past RANGE 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; Note_Feature (Modular_Integer_Types, Token_Ptr); 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 comes before DIGITS, not after"); 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); Note_Feature (Decimal_Fixed_Point, Token_Ptr); 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 Note_Feature (Aliased_Objects, Token_Ptr); 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_Expression; Check_Simple_Expression (Expr_Node); if 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); -- All set if range attribute scanned elsif Token = Tok_Apostrophe then return P_Range_Attribute_Reference (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; Note_Feature (Unknown_Discriminant_Parts, Token_Ptr); 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; Note_Feature (Access_Discriminants, Token_Ptr); 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; -- Check range constraint if 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 range attribute elsif Token = Tok_Apostrophe then Append (P_Range_Attribute_Reference (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; Scan; -- past 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; 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); if Token = Tok_Null then Scan; -- past NULL Set_Null_Present (Component_List_Node, True); TF_Semicolon; return Component_List_Node; else Decls_List := New_List; 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 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); end if; Set_Component_Items (Component_List_Node, Decls_List); return Component_List_Node; end if; 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; 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; 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, Token_Ptr); 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 Note_Feature (Aliased_Objects, Token_Ptr); 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; Range_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 := P_Expression_No_Right_Paren; if Token = Tok_Dot_Dot then Choice_Node := New_Node (N_Range, Token_Ptr); Check_Simple_Expression (Expr_Node); 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 Token = Tok_Apostrophe then Append (P_Range_Attribute_Reference (Expr_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; exit when Token /= Tok_Vertical_Bar; Scan; -- past | 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; 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; Note_Feature (Access_To_Subprogram_Types, Token_Ptr); Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); Scan; -- past PROCEDURE 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; Note_Feature (Access_To_Subprogram_Types, Token_Ptr); Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); Scan; -- past FUNCTION 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 Note_Feature (General_Access_Types, Token_Ptr); Set_All_Present (Type_Def_Node, True); else Note_Feature (Access_To_Constant_Types, Token_Ptr); 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, Missing_Begin_Msg, 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; Msg_Id : in out Error_Msg_Id; 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 => Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_For => Append (P_Representation_Clause, Decls); Done := False; when Tok_Generic => Append (P_Generic, Decls); Done := False; when Tok_Identifier => P_Identifier_Declarations (Decls, Done, Msg_Id, In_Spec); when Tok_Package => Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_Pragma => Append (P_Pragma, Decls); Done := False; when Tok_Procedure => Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_Protected => Scan; -- past PROTECTED Append (P_Protected, Decls); Done := False; when Tok_Subtype => Append (P_Subtype_Declaration, Decls); Done := False; when Tok_Task => Scan; -- past TASK Append (P_Task, Decls); Done := False; when Tok_Type => Append (P_Type_Declaration, Decls); Done := False; when Tok_Use => Append (P_Use_Clause, Decls); Done := False; -- 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; Outer_Decls : List_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 semicolon" (SIS_Missing_Semicolon_Message, "missing ""is"" "); -- Otherwise we saved the semicolon position, so complain else Error_Msg ("semicolon 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; 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, Msg_Id, In_Spec); -- 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, Msg_Id, In_Spec); end if; -- If not reserved identifier, then it's definitely a statement else Statement_When_Declaration_Expected (Decls, Done, Msg_Id, 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"); Scan; -- past RETURN raise Error_Resync; -- PRIVATE definitely terminates the declarations, and we don't -- check for a misuse of a reserved keyword in this case. when Tok_Private => Done := True; -- 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 to 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); Error_Msg_SC ("declaration expected"); Resync_Past_Semicolon; Done := True; else Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); P_Identifier_Declarations (Decls, Done, Msg_Id, In_Spec); end if; else Error_Msg_SC ("declaration expected"); Resync_Past_Semicolon; Done := True; 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; Msg : Error_Msg_Id := No_Error_Msg; 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, Msg, 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 body scanned, not acceptable as basic declarative item 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)); end if; Decl := 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) ----------------------------------------- -- Statement_When_Declaration_Expected -- ----------------------------------------- procedure Statement_When_Declaration_Expected (Decls : List_Id; Done : out Boolean; Msg_Id : in out Error_Msg_Id; In_Spec : Boolean) is begin -- Case of second occurrence of statement in one declaration sequence if Msg_Id /= 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. Msg_Id := 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;