+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P A R . C H 7 --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.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
-
-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;
projects / msp430-gcc.git / blobdiff