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