URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [par-ch3.adb] - Rev 729
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 3 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); -- Turn off subprogram body ordering check. Subprograms are in order -- by RM section rather than alphabetical. with Sinfo.CN; use Sinfo.CN; separate (Par) --------- -- Ch3 -- --------- 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 Check_Restricted_Expression (N : Node_Id); -- Check that the expression N meets the Restricted_Expression syntax. -- The syntax is as follows: -- -- RESTRICTED_EXPRESSION ::= -- RESTRICTED_RELATION {and RESTRICTED_RELATION} -- | RESTRICTED_RELATION {and then RESTRICTED_RELATION} -- | RESTRICTED_RELATION {or RESTRICTED_RELATION} -- | RESTRICTED_RELATION {or else RESTRICTED_RELATION} -- | RESTRICTED_RELATION {xor RESTRICTED_RELATION} -- -- RESTRICTED_RELATION ::= -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] -- -- This syntax is used for choices when extensions (and set notations) -- are enabled, to remove the ambiguity of "when X in A | B". We consider -- it very unlikely that this will ever arise in practice. 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. --------------------------------- -- Check_Restricted_Expression -- --------------------------------- procedure Check_Restricted_Expression (N : Node_Id) is begin if Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor, N_And_Then, N_Or_Else) then Check_Restricted_Expression (Left_Opnd (N)); Check_Restricted_Expression (Right_Opnd (N)); elsif Nkind_In (N, N_In, N_Not_In) and then Paren_Count (N) = 0 then Error_Msg_N ("|this expression must be parenthesized!", N); end if; end Check_Restricted_Expression; ------------------- -- Init_Expr_Opt -- ------------------- function Init_Expr_Opt (P : Boolean := False) return Node_Id is begin -- For colon, assume it means := unless it is at the end of -- a line, in which case guess that it means a semicolon. if Token = Tok_Colon then if Token_Is_At_End_Of_Line then T_Semicolon; return Empty; end if; -- Here if := or something that we will take as equivalent elsif Token = Tok_Colon_Equal or else Token = Tok_Equal or else Token = Tok_Is then null; -- Another 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 (C : Id_Check := None) 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. -- Duplication should be removed, common code should be factored??? if Token = Tok_Identifier then Check_Future_Keyword; -- If we have a reserved identifier, manufacture an identifier with -- a corresponding name after posting an appropriate error message elsif Is_Reserved_Identifier (C) 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 we already have a defining identifier, clean it out and make -- a new clean identifier. This situation arises in some error cases -- and we need to fix it. if Nkind (Ident_Node) = N_Defining_Identifier then Ident_Node := Make_Identifier (Sloc (Ident_Node), Chars (Ident_Node)); end if; -- Change identifier to defining identifier if not in error 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 -- [ASPECT_SPECIFICATIONS]; -- | CONCURRENT_TYPE_DECLARATION -- INCOMPLETE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] [is tagged]; -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] -- is [abstract] [tagged] [limited] private; -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- [abstract] [limited | synchronized] -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] -- 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 | INTERFACE_TYPE_DEFINITION -- INTEGER_TYPE_DEFINITION ::= -- SIGNED_INTEGER_TYPE_DEFINITION -- MODULAR_TYPE_DEFINITION -- INTERFACE_TYPE_DEFINITION ::= -- [limited | task | protected | synchronized ] interface -- [and INTERFACE_LIST] -- Error recovery: can raise Error_Resync -- The processing for full type declarations, incomplete type declarations, -- private type declarations and type definitions is included in this -- function. The processing for concurrent type declarations is NOT here, -- but rather in chapter 9 (this function handles only declarations -- starting with TYPE). function P_Type_Declaration return Node_Id is Abstract_Present : Boolean := False; Abstract_Loc : Source_Ptr := No_Location; Decl_Node : Node_Id; Discr_List : List_Id; Discr_Sloc : Source_Ptr; End_Labl : Node_Id; Ident_Node : Node_Id; Is_Derived_Iface : Boolean := False; Type_Loc : Source_Ptr; Type_Start_Col : Column_Number; Unknown_Dis : Boolean; 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; -- If we have TYPE, then proceed ahead and scan identifier if Token = Tok_Type then Type_Token_Location := Type_Loc; Scan; -- past TYPE Ident_Node := P_Defining_Identifier (C_Is); -- Otherwise this is an error case else T_Type; Type_Token_Location := Type_Loc; Ident_Node := P_Defining_Identifier (C_Is); end if; 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 -- CODEFIX ("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 -- Ada 2005 (AI-419): AARM 3.4 (2/2) if (Ada_Version < Ada_2005 and then 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; 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 processing 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 | Tok_Not => -- Ada 2005 (AI-231) Typedef_Node := P_Access_Type_Definition; exit; when Tok_Array => Typedef_Node := P_Array_Type_Definition; exit; when Tok_Delta => Typedef_Node := P_Fixed_Point_Definition; exit; when Tok_Digits => Typedef_Node := P_Floating_Point_Definition; exit; when Tok_In => Ignore (Tok_In); when Tok_Integer_Literal => T_Range; Typedef_Node := P_Signed_Integer_Type_Definition; exit; when Tok_Null => Typedef_Node := P_Record_Definition; exit; when Tok_Left_Paren => Typedef_Node := P_Enumeration_Type_Definition; End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Typedef_Node, End_Labl); exit; when Tok_Mod => Typedef_Node := P_Modular_Type_Definition; exit; when Tok_New => Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; if Nkind (Typedef_Node) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Typedef_Node)) then End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Record_Extension_Part (Typedef_Node), End_Labl); end if; exit; when Tok_Range => Typedef_Node := P_Signed_Integer_Type_Definition; exit; when Tok_Record => Typedef_Node := P_Record_Definition; End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Typedef_Node, End_Labl); exit; when Tok_Tagged => Scan; -- past TAGGED -- Ada 2005 (AI-326): If the words IS TAGGED appear, the type -- is a tagged incomplete type. if Ada_Version >= Ada_2005 and then Token = Tok_Semicolon then Scan; -- past ; Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); Set_Defining_Identifier (Decl_Node, Ident_Node); Set_Tagged_Present (Decl_Node); Set_Unknown_Discriminants_Present (Decl_Node, Unknown_Dis); Set_Discriminant_Specifications (Decl_Node, Discr_List); return Decl_Node; end if; if Token = Tok_Abstract then Error_Msg_SC -- CODEFIX ("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_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Typedef_Node, End_Labl); 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_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Typedef_Node, End_Labl); end if; end if; exit; when Tok_Limited => Scan; -- past LIMITED loop if Token = Tok_Tagged then Error_Msg_SC -- CODEFIX ("TAGGED must come before LIMITED"); Scan; -- past TAGGED elsif Token = Tok_Abstract then Error_Msg_SC -- CODEFIX ("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_Version = Ada_83 then Error_Msg_SP ("(Ada 83) limited record declaration not allowed!"); -- In Ada 2005, "abstract limited" can appear before "new", -- but it cannot be part of an untagged record declaration. elsif Abstract_Present and then Prev_Token /= Tok_Tagged then Error_Msg_SP ("TAGGED expected"); end if; Typedef_Node := P_Record_Definition; Set_Limited_Present (Typedef_Node, True); -- Ada 2005 (AI-251): LIMITED INTERFACE -- If we are compiling in Ada 83 or Ada 95 mode, "interface" -- is not a reserved word but we force its analysis to -- generate the corresponding usage error. elsif Token = Tok_Interface or else (Token = Tok_Identifier and then Chars (Token_Node) = Name_Interface) then Typedef_Node := P_Interface_Type_Definition (Abstract_Present); Abstract_Present := True; Set_Limited_Present (Typedef_Node); if Nkind (Typedef_Node) = N_Derived_Type_Definition then Is_Derived_Iface := True; end if; -- Ada 2005 (AI-419): LIMITED NEW elsif Token = Tok_New then if Ada_Version < Ada_2005 then Error_Msg_SP ("LIMITED in derived type is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; Set_Limited_Present (Typedef_Node); if Nkind (Typedef_Node) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Typedef_Node)) then End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); Set_Comes_From_Source (End_Labl, False); Set_End_Label (Record_Extension_Part (Typedef_Node), End_Labl); end if; -- 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; 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; -- 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; end if; exit; -- Ada 2005 (AI-251): INTERFACE when Tok_Interface => Typedef_Node := P_Interface_Type_Definition (Abstract_Present); Abstract_Present := True; exit; when Tok_Private => Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Scan; -- past PRIVATE -- Check error cases of private [abstract] tagged if Token = Tok_Abstract then Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); Scan; -- past ABSTRACT if Token = Tok_Tagged then Scan; -- past TAGGED end if; elsif Token = Tok_Tagged then Error_Msg_SC ("TAGGED must come before PRIVATE"); Scan; -- past TAGGED end if; exit; -- Ada 2005 (AI-345): Protected, synchronized or task interface -- or Ada 2005 (AI-443): Synchronized private extension. when Tok_Protected | Tok_Synchronized | Tok_Task => declare Saved_Token : constant Token_Type := Token; begin Scan; -- past TASK, PROTECTED or SYNCHRONIZED -- Synchronized private extension if Token = Tok_New then Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; if Saved_Token = Tok_Synchronized then if Nkind (Typedef_Node) = N_Derived_Type_Definition then Error_Msg_N ("SYNCHRONIZED not allowed for record extension", Typedef_Node); else Set_Synchronized_Present (Typedef_Node); end if; else Error_Msg_SC ("invalid kind of private extension"); end if; -- Interface else if Token /= Tok_Interface then Error_Msg_SC ("NEW or INTERFACE expected"); end if; Typedef_Node := P_Interface_Type_Definition (Abstract_Present); Abstract_Present := True; case Saved_Token is when Tok_Task => Set_Task_Present (Typedef_Node); when Tok_Protected => Set_Protected_Present (Typedef_Node); when Tok_Synchronized => Set_Synchronized_Present (Typedef_Node); when others => pragma Assert (False); null; end case; end if; end; 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))) or else Is_Derived_Iface 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); P_Aspect_Specifications (Decl_Node); 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 [NULL_EXCLUSION] SUBTYPE_INDICATION -- {ASPECT_SPECIFICATIONS]; -- 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; Not_Null_Present : Boolean := False; begin Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); Scan; -- past SUBTYPE Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is)); TF_Is; if Token = Tok_New then Error_Msg_SC -- CODEFIX ("NEW ignored (only allowed in type declaration)"); Scan; -- past NEW end if; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Subtype_Indication (Decl_Node, P_Subtype_Indication (Not_Null_Present)); P_Aspect_Specifications (Decl_Node); return Decl_Node; end P_Subtype_Declaration; ------------------------------- -- 3.2.2 Subtype Indication -- ------------------------------- -- SUBTYPE_INDICATION ::= -- [not null] SUBTYPE_MARK [CONSTRAINT] -- Error recovery: can raise Error_Resync function P_Null_Exclusion (Allow_Anonymous_In_95 : Boolean := False) return Boolean is Not_Loc : constant Source_Ptr := Token_Ptr; -- Source position of "not", if present begin if Token /= Tok_Not then return False; else Scan; -- past NOT if Token = Tok_Null then Scan; -- past NULL -- Ada 2005 (AI-441, AI-447): null_exclusion is illegal in Ada 95, -- except in the case of anonymous access types. -- Allow_Anonymous_In_95 will be True if we're parsing a formal -- parameter or discriminant, which are the only places where -- anonymous access types occur in Ada 95. "Formal : not null -- access ..." is legal in Ada 95, whereas "Formal : not null -- Named_Access_Type" is not. if Ada_Version >= Ada_2005 or else (Ada_Version >= Ada_95 and then Allow_Anonymous_In_95 and then Token = Tok_Access) then null; -- OK else Error_Msg ("`NOT NULL` access type is an Ada 2005 extension", Not_Loc); Error_Msg ("\unit should be compiled with -gnat05 switch", Not_Loc); end if; else Error_Msg_SP ("NULL expected"); end if; if Token = Tok_New then Error_Msg ("`NOT NULL` comes after NEW, not before", Not_Loc); end if; return True; end if; end P_Null_Exclusion; function P_Subtype_Indication (Not_Null_Present : Boolean := False) 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, Not_Null_Present); 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; Not_Null_Present : Boolean := False) return Node_Id is Indic_Node : Node_Id; Constr_Node : Node_Id; begin Constr_Node := P_Constraint_Opt; if No (Constr_Node) or else (Nkind (Constr_Node) = N_Range_Constraint and then Nkind (Range_Expression (Constr_Node)) = N_Error) then return Subtype_Mark; else if Not_Null_Present then Error_Msg_SP ("`NOT NULL` not allowed if constraint given"); end if; 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 Error; 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); 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 : [aliased] [constant] -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION] -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ACCESS_DEFINITION [:= EXPRESSION] -- [ASPECT_SPECIFICATIONS]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION] -- [ASPECT_SPECIFICATIONS]; -- NUMBER_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; -- | DEFINING_IDENTIFIER : -- ACCESS_DEFINITION renames object_NAME; -- EXCEPTION_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : exception renames exception_NAME; -- EXCEPTION_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : exception -- [ASPECT_SPECIFICATIONS]; -- 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 Acc_Node : Node_Id; 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; Not_Null_Present : Boolean := False; 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. ------------- -- No_List -- ------------- 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; ---------------------- -- Token_Is_Renames -- ---------------------- 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 -- CODEFIX ("|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 (C_Comma_Colon); -- 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 (C_Comma_Colon); 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 if Not_Null_Present then Error_Msg_SP ("`NOT NULL` not allowed in numeric expression"); end if; 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 -- CODEFIX ("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 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Set_Object_Definition (Decl_Node, P_Access_Definition (Not_Null_Present)); else Set_Object_Definition (Decl_Node, P_Subtype_Indication (Not_Null_Present)); end if; 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 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); -- Access definition (AI-406) or subtype indication if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Set_Object_Definition (Decl_Node, P_Access_Definition (Not_Null_Present)); else Set_Object_Definition (Decl_Node, P_Subtype_Indication (Not_Null_Present)); end if; 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); -- Ada 2005 (AI-254, AI-406) elsif Token = Tok_Not then -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- [NULL_EXCLUSION] SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ACCESS_DEFINITION [:= EXPRESSION]; -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : -- [NULL_EXCLUSION] SUBTYPE_MARK renames object_NAME; -- | DEFINING_IDENTIFIER : -- ACCESS_DEFINITION renames object_NAME; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/423) if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Acc_Node := P_Access_Definition (Not_Null_Present); if Token /= Tok_Renames then Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, Acc_Node); else Scan; -- past renames No_List; Decl_Node := New_Node (N_Object_Renaming_Declaration, Ident_Sloc); Set_Access_Definition (Decl_Node, Acc_Node); Set_Name (Decl_Node, P_Name); end if; else Type_Node := P_Subtype_Mark; -- Object renaming declaration if Token_Is_Renames then if Ada_Version < Ada_2005 then Error_Msg_SP ("`NOT NULL` not allowed in object renaming"); raise Error_Resync; -- Ada 2005 (AI-423): Object renaming declaration with -- a null exclusion. else No_List; Decl_Node := New_Node (N_Object_Renaming_Declaration, Ident_Sloc); Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Subtype_Mark (Decl_Node, Type_Node); Set_Name (Decl_Node, P_Name); end if; -- Object declaration else Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Object_Definition (Decl_Node, P_Subtype_Indication (Type_Node, Not_Null_Present)); -- 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; -- Ada 2005 (AI-230): Access Definition case elsif Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Acc_Node := P_Access_Definition (Null_Exclusion_Present => False); -- Object declaration with access definition, or renaming if Token /= Tok_Renames then Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, Acc_Node); else Scan; -- past renames No_List; Decl_Node := New_Node (N_Object_Renaming_Declaration, Ident_Sloc); Set_Access_Definition (Decl_Node, Acc_Node); Set_Name (Decl_Node, P_Name); end if; -- 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_Null_Exclusion_Present (Decl_Node, Not_Null_Present); Set_Object_Definition (Decl_Node, P_Subtype_Indication (Type_Node, Not_Null_Present)); -- 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); Set_Has_Init_Expression (Decl_Node); else Error_Msg ("initialization not allowed here", Init_Loc); end if; end if; Set_Defining_Identifier (Decl_Node, Idents (Ident)); P_Aspect_Specifications (Decl_Node); 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] [limited] new [NULL_EXCLUSION] parent_SUBTYPE_INDICATION -- [[and INTERFACE_LIST] RECORD_EXTENSION_PART] -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- [abstract] [limited | synchronized] -- new ancestor_SUBTYPE_INDICATION [and INTERFACE_LIST] -- 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; Not_Null_Present : Boolean := False; begin Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); if Ada_Version < Ada_2005 and then Token = Tok_Identifier and then Token_Name = Name_Interface then Error_Msg_SP ("abstract interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); else T_New; end if; if Token = Tok_Abstract then Error_Msg_SC -- CODEFIX ("ABSTRACT must come before NEW, not after"); Scan; end if; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Set_Null_Exclusion_Present (Typedef_Node, Not_Null_Present); Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication (Not_Null_Present)); -- Ada 2005 (AI-251): Deal with interfaces if Token = Tok_And then Scan; -- past AND if Ada_Version < Ada_2005 then Error_Msg_SP ("abstract interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; Set_Interface_List (Typedef_Node, New_List); loop Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node)); exit when Token /= Tok_And; Scan; -- past AND end loop; if Token /= Tok_With then Error_Msg_SC ("WITH expected"); raise Error_Resync; end if; end if; -- 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". -- First make sure we don't have an aspect specification. If we do -- return now, so that our caller can check it (the WITH here is not -- part of a type extension). if Aspect_Specifications_Present then return Typedef_Node; -- OK, not an aspect specification, so continue test for extension elsif 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), Interface_List => Interface_List (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 (it is not used in any other contexts, and -- error messages are specialized with this knowledge in mind). -- 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 (Allow_Simple_Expression : Boolean := False) return Node_Id is Expr_Node : Node_Id; Range_Node : Node_Id; Save_Loc : Source_Ptr; -- Start of processing for P_Range_Or_Subtype_Mark begin -- Save location of possible junk parentheses Save_Loc := Token_Ptr; -- Scan out either a simple expression or a range (this accepts more -- than is legal here, but as explained above, we like to allow more -- with a proper diagnostic, and in the case of a membership operation -- where sets are allowed, a simple expression is permissible anyway. Expr_Node := P_Simple_Expression_Or_Range_Attribute; -- 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 qualified 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; -- Attribute reference, may or may not be OK, but in any case we -- will scan it out elsif Token = Tok_Apostrophe then return P_Subtype_Mark_Attribute (Expr_Node); -- OK case of simple name, just return it else return Expr_Node; end if; -- Simple expression case elsif Expr_Form = EF_Simple and then Allow_Simple_Expression then return Expr_Node; -- Here we have some kind of error situation. Check for junk parens -- then return what we have, caller will deal with other errors. else if Nkind (Expr_Node) in N_Subexpr and then Paren_Count (Expr_Node) /= 0 then Error_Msg ("|parentheses not allowed for subtype mark", Save_Loc); Set_Paren_Count (Expr_Node, 0); end if; 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 (C_Comma_Right_Paren); 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_Or_Range_Attribute; -- Range case (not permitted by the grammar, this is surprising but -- the grammar in the RM is as quoted above, and does not allow Range). if Expr_Form = EF_Range_Attr then Error_Msg_N ("Range attribute not allowed here, use First .. Last", Expr_Node); Set_Low_Bound (Typedef_Node, Expr_Node); Set_Attribute_Name (Expr_Node, Name_First); Set_High_Bound (Typedef_Node, Copy_Separate_Tree (Expr_Node)); Set_Attribute_Name (High_Bound (Typedef_Node), Name_Last); -- Normal case of explicit range else 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); end if; 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_Version = 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 -- CODEFIX ("|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_Version = 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; 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 -- (also true in formal modes). -- 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; 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] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION -- 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; CompDef_Node : Node_Id; Def_Node : Node_Id; Not_Null_Present : Boolean := False; Subs_List : List_Id; Scan_State : Saved_Scan_State; Aliased_Present : Boolean := False; 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; CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); if Token_Name = Name_Aliased then Check_95_Keyword (Tok_Aliased, Tok_Identifier); end if; if Token = Tok_Aliased then Aliased_Present := True; Scan; -- past ALIASED end if; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) -- Ada 2005 (AI-230): Access Definition case if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; -- AI95-406 makes "aliased" legal (and useless) in this context so -- followintg code which used to be needed is commented out. -- if Aliased_Present then -- Error_Msg_SP ("ALIASED not allowed here"); -- end if; Set_Subtype_Indication (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, False); Set_Access_Definition (CompDef_Node, P_Access_Definition (Not_Null_Present)); else Set_Access_Definition (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, Aliased_Present); Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication (Not_Null_Present)); end if; Set_Component_Definition (Def_Node, CompDef_Node); 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, or an Ada 2012 iterator elsif Expr_Form = EF_Simple_Name then return Expr_Node; -- The domain of iteration must be a name. Semantics will determine that -- the expression has the proper form. elsif Ada_Version >= Ada_2012 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 <> right now, then this is missing left paren if Token = Tok_Box then U_Left_Paren; -- If not <> or left paren, then definitely no box elsif Token /= Tok_Left_Paren then return False; -- Left paren, so might be a box after it else Save_Scan_State (Scan_State); Scan; -- past the left paren if Token /= Tok_Box then Restore_Scan_State (Scan_State); return False; end if; end if; -- We are now pointing to the box if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) unknown discriminant not allowed!"); end if; Scan; -- past the box U_Right_Paren; -- must be followed by right paren return True; end P_Unknown_Discriminant_Part_Opt; ---------------------------------- -- 3.7 Known Discriminant Part -- ---------------------------------- -- KNOWN_DISCRIMINANT_PART ::= -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) -- DISCRIMINANT_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : [NULL_EXCLUSION] 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; Not_Null_Present : Boolean; 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 (C_Comma_Colon); Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); end loop; -- 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; T_Colon; -- 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)); Not_Null_Present := -- Ada 2005 (AI-231, AI-447) P_Null_Exclusion (Allow_Anonymous_In_95 => True); if Token = Tok_Access then if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) access discriminant not allowed!"); end if; Set_Discriminant_Type (Specification_Node, P_Access_Definition (Not_Null_Present)); else Set_Discriminant_Type (Specification_Node, P_Subtype_Mark); No_Constraint; Set_Null_Exclusion_Present -- Ada 2005 (AI-231) (Specification_Node, Not_Null_Present); 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); T_Colon; 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 (C_Vertical_Bar_Arrow), 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); -- Catch incomplete declaration to prevent cascaded errors, see -- ACATS B393002 for an example. elsif Token = Tok_Semicolon then Error_Msg_AP ("missing record definition"); -- 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, and -- in particular is standard GNAT coding style, so handle it nicely. 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] -- [ASPECT_SPECIFICATIONS]; -- COMPONENT_DEFINITION ::= -- [aliased] [NULL_EXCLUSION] SUBTYPE_INDICATION | ACCESS_DEFINITION -- 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 Aliased_Present : Boolean := False; CompDef_Node : Node_Id; Decl_Node : Node_Id; Scan_State : Saved_Scan_State; Not_Null_Present : Boolean := False; 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 (C_Comma_Colon); Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); end loop; -- 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; T_Colon; -- 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; CompDef_Node := New_Node (N_Component_Definition, Token_Ptr); if Token_Name = Name_Aliased then Check_95_Keyword (Tok_Aliased, Tok_Identifier); end if; if Token = Tok_Aliased then Aliased_Present := True; Scan; -- past ALIASED end if; Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231/AI-254) -- Ada 2005 (AI-230): Access Definition case if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SP ("generalized use of anonymous access types " & "is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; -- AI95-406 makes "aliased" legal (and useless) here, so the -- following code which used to be required is commented out. -- if Aliased_Present then -- Error_Msg_SP ("ALIASED not allowed here"); -- end if; Set_Subtype_Indication (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, False); Set_Access_Definition (CompDef_Node, P_Access_Definition (Not_Null_Present)); else Set_Access_Definition (CompDef_Node, Empty); Set_Aliased_Present (CompDef_Node, Aliased_Present); Set_Null_Exclusion_Present (CompDef_Node, Not_Null_Present); if Token = Tok_Array then Error_Msg_SC ("anonymous arrays not allowed as components"); raise Error_Resync; end if; Set_Subtype_Indication (CompDef_Node, P_Subtype_Indication (Not_Null_Present)); end if; Set_Component_Definition (Decl_Node, CompDef_Node); 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); T_Colon; end loop Ident_Loop; P_Aspect_Specifications (Decl_Node); 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; 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; 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)); elsif Paren_Count (Case_Node) /= 0 then Error_Msg ("|discriminant name may not be parenthesized", Sloc (Case_Node)); Set_Paren_Count (Case_Node, 0); 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 -- Scan out expression or range attribute Expr_Node := P_Expression_Or_Range_Attribute; Ignore (Tok_Right_Paren); if Token = Tok_Colon and then Nkind (Expr_Node) = N_Identifier then Error_Msg_SP ("label not permitted in this context"); Scan; -- past colon -- Range attribute elsif Expr_Form = EF_Range_Attr then Append (Expr_Node, Choices); -- Explicit range 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); -- Simple name, must be subtype, so range allowed 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; -- Expression else -- In Ada 2012 mode, the expression must be a simple -- expression. The reason for this restriction (i.e. going -- back to the Ada 83 rule) is to avoid ambiguities when set -- membership operations are allowed, consider the -- following: -- when A in 1 .. 10 | 12 => -- This is ambiguous without parentheses, so we require one -- of the following two parenthesized forms to disambiguate: -- one of the following: -- when (A in 1 .. 10 | 12) => -- when (A in 1 .. 10) | 12 => -- To solve this, in Ada 2012 mode, we disallow the use of -- membership operations in expressions in choices. -- Technically in the grammar, the expression must match the -- grammar for restricted expression. if Ada_Version >= Ada_2012 then Check_Restricted_Expression (Expr_Node); -- In Ada 83 mode, the syntax required a simple expression else Check_Simple_Expression_In_Ada_83 (Expr_Node); end if; Append (Expr_Node, Choices); end if; exception when Error_Resync => Resync_Choice; return Error_List; end; end if; if Token = Tok_Comma then Scan; -- past comma if Token = Tok_Vertical_Bar then Error_Msg_SP -- CODEFIX ("|extra "","" ignored"); Scan; -- past | else Error_Msg_SP -- CODEFIX (""","" should be ""'|"""); end if; else exit when Token /= Tok_Vertical_Bar; Scan; -- past | end if; 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.9.4 Interface Type Definition -- -------------------------------------- -- INTERFACE_TYPE_DEFINITION ::= -- [limited | task | protected | synchronized] interface -- [and INTERFACE_LIST] -- Error recovery: cannot raise Error_Resync function P_Interface_Type_Definition (Abstract_Present : Boolean) return Node_Id is Typedef_Node : Node_Id; begin if Ada_Version < Ada_2005 then Error_Msg_SP ("abstract interface is an Ada 2005 extension"); Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); end if; if Abstract_Present then Error_Msg_SP ("ABSTRACT not allowed in interface type definition " & "(RM 3.9.4(2/2))"); end if; Scan; -- past INTERFACE -- Ada 2005 (AI-345): In case of interfaces with a null list of -- interfaces we build a record_definition node. if Token = Tok_Semicolon or else Aspect_Specifications_Present then Typedef_Node := New_Node (N_Record_Definition, Token_Ptr); Set_Abstract_Present (Typedef_Node); Set_Tagged_Present (Typedef_Node); Set_Null_Present (Typedef_Node); Set_Interface_Present (Typedef_Node); -- Ada 2005 (AI-251): In case of not-synchronized interfaces that have -- a list of interfaces we build a derived_type_definition node. This -- simplifies the semantic analysis (and hence further maintenance) else if Token /= Tok_And then Error_Msg_AP ("AND expected"); else Scan; -- past AND end if; Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); Set_Abstract_Present (Typedef_Node); Set_Interface_Present (Typedef_Node); Set_Subtype_Indication (Typedef_Node, P_Qualified_Simple_Name); Set_Record_Extension_Part (Typedef_Node, New_Node (N_Record_Definition, Token_Ptr)); Set_Null_Present (Record_Extension_Part (Typedef_Node)); if Token = Tok_And then Set_Interface_List (Typedef_Node, New_List); Scan; -- past AND loop Append (P_Qualified_Simple_Name, Interface_List (Typedef_Node)); exit when Token /= Tok_And; Scan; -- past AND end loop; end if; end if; return Typedef_Node; end P_Interface_Type_Definition; ---------------------------------- -- 3.10 Access Type Definition -- ---------------------------------- -- ACCESS_TYPE_DEFINITION ::= -- ACCESS_TO_OBJECT_DEFINITION -- | ACCESS_TO_SUBPROGRAM_DEFINITION -- ACCESS_TO_OBJECT_DEFINITION ::= -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION -- GENERAL_ACCESS_MODIFIER ::= all | constant -- ACCESS_TO_SUBPROGRAM_DEFINITION -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE -- | [NULL_EXCLUSION] access [protected] function -- PARAMETER_AND_RESULT_PROFILE -- PARAMETER_PROFILE ::= [FORMAL_PART] -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK -- Ada 2005 (AI-254): If Header_Already_Parsed then the caller has already -- parsed the null_exclusion part and has also removed the ACCESS token; -- otherwise the caller has just checked that the initial token is ACCESS -- Error recovery: can raise Error_Resync function P_Access_Type_Definition (Header_Already_Parsed : Boolean := False) return Node_Id is Access_Loc : constant Source_Ptr := Token_Ptr; Prot_Flag : Boolean; Not_Null_Present : Boolean := False; Type_Def_Node : Node_Id; Result_Not_Null : Boolean; Result_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. -------------------------------- -- Check_Junk_Subprogram_Name -- -------------------------------- 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 if not Header_Already_Parsed then Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Scan; -- past ACCESS end if; 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 -- CODEFIX ("FUNCTION or PROCEDURE expected"); end if; end if; if Token = Tok_Procedure then if Ada_Version = 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); Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 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_Version = 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); Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); 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; Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) -- Ada 2005 (AI-318-02) if Token = Tok_Access then if Ada_Version < Ada_2005 then Error_Msg_SC ("anonymous access result type is an Ada 2005 extension"); Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); end if; Result_Node := P_Access_Definition (Result_Not_Null); else Result_Node := P_Subtype_Mark; No_Constraint; -- A null exclusion on the result type must be recorded in a flag -- distinct from the one used for the access-to-subprogram type's -- null exclusion. Set_Null_Exclusion_In_Return_Present (Type_Def_Node, Result_Not_Null); end if; Set_Result_Definition (Type_Def_Node, Result_Node); else Type_Def_Node := New_Node (N_Access_To_Object_Definition, Access_Loc); Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); if Token = Tok_All or else Token = Tok_Constant then if Ada_Version = 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 (Not_Null_Present)); 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 ::= -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK -- | ACCESS_TO_SUBPROGRAM_DEFINITION -- -- ACCESS_TO_SUBPROGRAM_DEFINITION -- [NULL_EXCLUSION] access [protected] procedure PARAMETER_PROFILE -- | [NULL_EXCLUSION] access [protected] function -- PARAMETER_AND_RESULT_PROFILE -- The caller has parsed the null-exclusion part and it has also checked -- that the next token is ACCESS -- Error recovery: cannot raise Error_Resync function P_Access_Definition (Null_Exclusion_Present : Boolean) return Node_Id is Def_Node : Node_Id; Subp_Node : Node_Id; begin Def_Node := New_Node (N_Access_Definition, Token_Ptr); Scan; -- past ACCESS -- Ada 2005 (AI-254): Access_To_Subprogram_Definition if Token = Tok_Protected or else Token = Tok_Procedure or else Token = Tok_Function then if Ada_Version < Ada_2005 then Error_Msg_SP ("access-to-subprogram is an Ada 2005 extension"); Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); end if; Subp_Node := P_Access_Type_Definition (Header_Already_Parsed => True); Set_Null_Exclusion_Present (Subp_Node, Null_Exclusion_Present); Set_Access_To_Subprogram_Definition (Def_Node, Subp_Node); -- Ada 2005 (AI-231) -- [NULL_EXCLUSION] access [GENERAL_ACCESS_MODIFIER] SUBTYPE_MARK else Set_Null_Exclusion_Present (Def_Node, Null_Exclusion_Present); if Token = Tok_All then if Ada_Version < Ada_2005 then Error_Msg_SP ("ALL is not permitted for anonymous access types"); end if; Scan; -- past ALL Set_All_Present (Def_Node); elsif Token = Tok_Constant then if Ada_Version < Ada_2005 then Error_Msg_SP ("access-to-constant is an Ada 2005 extension"); Error_Msg_SP ("\unit should be compiled with -gnat05 switch"); end if; Scan; -- past CONSTANT Set_Constant_Present (Def_Node); end if; Set_Subtype_Mark (Def_Node, P_Subtype_Mark); No_Constraint; end if; 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_Pexp), 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; -- Special check for misuse of overriding not in Ada 2005 mode if Token_Name = Name_Overriding and then not Next_Token_Is (Tok_Colon) then Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); Token := Tok_Overriding; Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; -- Normal case, no overriding, or overriding followed by colon else P_Identifier_Declarations (Decls, Done, In_Spec); end if; -- Ada 2005: A subprogram declaration can start with "not" or -- "overriding". In older versions, "overriding" is handled -- like an identifier, with the appropriate messages. when Tok_Not => Check_Bad_Layout; Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; when Tok_Overriding => Check_Bad_Layout; Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls); Done := False; when Tok_Package => Check_Bad_Layout; Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), 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_Pexp), 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; if Aspect_Specifications_Present then -- If we are after a semicolon, complain that it was ignored. -- But we don't really ignore it, since we dump the aspects, -- so we make the error message a normal fatal message which -- will inhibit semantic analysis anyway). if Prev_Token = Tok_Semicolon then Error_Msg_SP -- CODEFIX ("extra "";"" ignored"); -- If not just past semicolon, just complain that aspects are -- not allowed at this point. else Error_Msg_SC ("aspect specifications not allowed here"); end if; declare Dummy_Node : constant Node_Id := New_Node (N_Package_Specification, Token_Ptr); pragma Warnings (Off, Dummy_Node); -- Dummy node to attach aspect specifications to. We will -- then throw them away. begin P_Aspect_Specifications (Dummy_Node, Semicolon => True); end; -- Here if not aspect specifications case else Error_Msg_SC ("WITH can only appear in context clause"); raise Error_Resync; end if; -- 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 -- CODEFIX ("|"";"" 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 response 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 -- Indicate no bad declarations detected yet in the current context: -- visible or private declarations of a package spec. 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; -- 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; pragma Warnings (Off, Dummy_Done); 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;
Go to most recent revision | Compare with Previous | Blame | View Log