diff options
Diffstat (limited to 'gcc-4.3.1/gcc/ada/par-ch7.adb')
| -rw-r--r-- | gcc-4.3.1/gcc/ada/par-ch7.adb | 279 |
1 files changed, 279 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/par-ch7.adb b/gcc-4.3.1/gcc/ada/par-ch7.adb new file mode 100644 index 000000000..2fdca9ae7 --- /dev/null +++ b/gcc-4.3.1/gcc/ada/par-ch7.adb @@ -0,0 +1,279 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P A R . C H 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram body ordering check. Subprograms are in order +-- by RM section rather than alphabetical + +separate (Par) +package body Ch7 is + + --------------------------------------------- + -- 7.1 Package (also 8.5.3, 10.1.3, 12.3) -- + --------------------------------------------- + + -- This routine scans out a package declaration, package body, or a + -- renaming declaration or generic instantiation starting with PACKAGE + + -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; + + -- PACKAGE_SPECIFICATION ::= + -- package DEFINING_PROGRAM_UNIT_NAME is + -- {BASIC_DECLARATIVE_ITEM} + -- [private + -- {BASIC_DECLARATIVE_ITEM}] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_BODY ::= + -- package body DEFINING_PROGRAM_UNIT_NAME is + -- DECLARATIVE_PART + -- [begin + -- HANDLED_SEQUENCE_OF_STATEMENTS] + -- end [[PARENT_UNIT_NAME .] IDENTIFIER] + + -- PACKAGE_RENAMING_DECLARATION ::= + -- package DEFINING_IDENTIFIER renames package_NAME; + + -- PACKAGE_BODY_STUB ::= + -- package body DEFINING_IDENTIFIER is separate; + + -- The value in Pf_Flags indicates which of these possible declarations + -- is acceptable to the caller: + + -- Pf_Flags.Spcn Set if specification OK + -- Pf_Flags.Decl Set if declaration OK + -- Pf_Flags.Gins Set if generic instantiation OK + -- Pf_Flags.Pbod Set if proper body OK + -- Pf_Flags.Rnam Set if renaming declaration OK + -- Pf_Flags.Stub Set if body stub OK + + -- If an inappropriate form is encountered, it is scanned out but an + -- error message indicating that it is appearing in an inappropriate + -- context is issued. The only possible settings for Pf_Flags are those + -- defined as constants in package Par. + + -- Note: in all contexts where a package specification is required, there + -- is a terminating semicolon. This semicolon is scanned out in the case + -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part + -- of the package specification (it's just too much trouble, and really + -- quite unnecessary, to deal with scanning out an END where the semicolon + -- after the END is not considered to be part of the END. + + -- The caller has checked that the initial token is PACKAGE + + -- Error recovery: cannot raise Error_Resync + + function P_Package (Pf_Flags : Pf_Rec) return Node_Id is + Package_Node : Node_Id; + Specification_Node : Node_Id; + Name_Node : Node_Id; + Package_Sloc : Source_Ptr; + + begin + Push_Scope_Stack; + Scope.Table (Scope.Last).Etyp := E_Name; + Scope.Table (Scope.Last).Ecol := Start_Column; + Scope.Table (Scope.Last).Lreq := False; + + Package_Sloc := Token_Ptr; + Scan; -- past PACKAGE + + if Token = Tok_Type then + Error_Msg_SC ("TYPE not allowed here"); + Scan; -- past TYPE + end if; + + -- Case of package body. Note that we demand a package body if that + -- is the only possibility (even if the BODY keyword is not present) + + if Token = Tok_Body or else Pf_Flags = Pf_Pbod then + if not Pf_Flags.Pbod then + Error_Msg_SC ("package body cannot appear here!"); + end if; + + T_Body; + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + TF_Is; + + if Separate_Present then + if not Pf_Flags.Stub then + Error_Msg_SC ("body stub cannot appear here!"); + end if; + + Scan; -- past SEPARATE + TF_Semicolon; + Pop_Scope_Stack; + + Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); + Set_Defining_Identifier (Package_Node, Name_Node); + + else + Package_Node := New_Node (N_Package_Body, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Parse_Decls_Begin_End (Package_Node); + end if; + + return Package_Node; + + -- Cases other than Package_Body + + else + Name_Node := P_Defining_Program_Unit_Name; + Scope.Table (Scope.Last).Labl := Name_Node; + + -- Case of renaming declaration + + Check_Misspelling_Of (Tok_Renames); + + if Token = Tok_Renames then + if not Pf_Flags.Rnam then + Error_Msg_SC ("renaming declaration cannot appear here!"); + end if; + + Scan; -- past RENAMES; + + Package_Node := + New_Node (N_Package_Renaming_Declaration, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + + No_Constraint; + TF_Semicolon; + Pop_Scope_Stack; + return Package_Node; + + else + TF_Is; + + -- Case of generic instantiation + + if Token = Tok_New then + if not Pf_Flags.Gins then + Error_Msg_SC + ("generic instantiation cannot appear here!"); + end if; + + Scan; -- past NEW + + Package_Node := + New_Node (N_Package_Instantiation, Package_Sloc); + Set_Defining_Unit_Name (Package_Node, Name_Node); + Set_Name (Package_Node, P_Qualified_Simple_Name); + Set_Generic_Associations + (Package_Node, P_Generic_Actual_Part_Opt); + TF_Semicolon; + Pop_Scope_Stack; + + -- Case of package declaration or package specification + + else + Specification_Node := + New_Node (N_Package_Specification, Package_Sloc); + + Set_Defining_Unit_Name (Specification_Node, Name_Node); + Set_Visible_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + if Token = Tok_Private then + Error_Msg_Col := Scope.Table (Scope.Last).Ecol; + + if Style.RM_Column_Check then + if Token_Is_At_Start_Of_Line + and then Start_Column /= Error_Msg_Col + then + Error_Msg_SC + ("(style) PRIVATE in wrong column, should be@"); + end if; + end if; + + Scan; -- past PRIVATE + Set_Private_Declarations + (Specification_Node, P_Basic_Declarative_Items); + + -- Deal gracefully with multiple PRIVATE parts + + while Token = Tok_Private loop + Error_Msg_SC + ("only one private part allowed per package"); + Scan; -- past PRIVATE + Append_List (P_Basic_Declarative_Items, + Private_Declarations (Specification_Node)); + end loop; + end if; + + if Pf_Flags = Pf_Spcn then + Package_Node := Specification_Node; + else + Package_Node := + New_Node (N_Package_Declaration, Package_Sloc); + Set_Specification (Package_Node, Specification_Node); + end if; + + if Token = Tok_Begin then + Error_Msg_SC ("begin block not allowed in package spec"); + Scan; -- past BEGIN + Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); + end if; + + End_Statements (Specification_Node); + end if; + + return Package_Node; + end if; + end if; + end P_Package; + + ------------------------------ + -- 7.1 Package Declaration -- + ------------------------------ + + -- Parsed by P_Package (7.1) + + -------------------------------- + -- 7.1 Package Specification -- + -------------------------------- + + -- Parsed by P_Package (7.1) + + ----------------------- + -- 7.1 Package Body -- + ----------------------- + + -- Parsed by P_Package (7.1) + + ----------------------------------- + -- 7.3 Private Type Declaration -- + ----------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + + ---------------------------------------- + -- 7.3 Private Extension Declaration -- + ---------------------------------------- + + -- Parsed by P_Type_Declaration (3.2.1) + +end Ch7; |