------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 7 -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2013, 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 -- [ASPECT_SPECIFICATIONS] -- is -- {BASIC_DECLARATIVE_ITEM} -- [private -- {BASIC_DECLARATIVE_ITEM}] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_BODY ::= -- package body DEFINING_PROGRAM_UNIT_NAME -- [ASPECT_SPECIFICATIONS] -- is -- DECLARATIVE_PART -- [begin -- HANDLED_SEQUENCE_OF_STATEMENTS] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_RENAMING_DECLARATION ::= -- package DEFINING_IDENTIFIER renames package_NAME -- [ASPECT_SPECIFICATIONS]; -- PACKAGE_BODY_STUB ::= -- package body DEFINING_IDENTIFIER is separate -- [ASPECT_SPECIFICATIONS]; -- PACKAGE_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is -- new generic_package_NAME [GENERIC_ACTUAL_PART] -- [ASPECT_SPECIFICATIONS]; -- 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; Aspect_Sloc : Source_Ptr := No_Location; -- Save location of WITH for scanned aspects. Left set to No_Location -- if no aspects scanned before the IS keyword. Is_Sloc : Source_Ptr; -- Save location of IS token for package declaration Dummy_Node : constant Node_Id := New_Node (N_Package_Specification, Token_Ptr); -- Dummy node to attach aspect specifications to until we properly -- figure out where they eventually belong. Body_Is_Hidden_In_SPARK : Boolean; Private_Part_Is_Hidden_In_SPARK : Boolean; Hidden_Region_Start : 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 -- CODEFIX ("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_Pexp then if not Pf_Flags.Pbod then Error_Msg_SC ("package body cannot appear here!"); end if; T_Body; Scope.Table (Scope.Last).Sloc := Token_Ptr; Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; if Aspect_Specifications_Present then Aspect_Sloc := Token_Ptr; P_Aspect_Specifications (Dummy_Node, Semicolon => False); end if; 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 Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); Set_Defining_Identifier (Package_Node, Name_Node); if Has_Aspects (Dummy_Node) then Error_Msg ("aspect specifications must come after SEPARATE", Aspect_Sloc); end if; P_Aspect_Specifications (Package_Node, Semicolon => False); TF_Semicolon; Pop_Scope_Stack; else Package_Node := New_Node (N_Package_Body, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); -- Move the aspect specifications to the body node if Has_Aspects (Dummy_Node) then Move_Aspects (From => Dummy_Node, To => Package_Node); end if; -- In SPARK, a HIDE directive can be placed at the beginning of a -- package implementation, thus hiding the package body from SPARK -- tool-set. No violation of the SPARK restriction should be -- issued on nodes in a hidden part, which is obtained by marking -- such hidden parts. if Token = Tok_SPARK_Hide then Body_Is_Hidden_In_SPARK := True; Hidden_Region_Start := Token_Ptr; Scan; -- past HIDE directive else Body_Is_Hidden_In_SPARK := False; end if; Parse_Decls_Begin_End (Package_Node); if Body_Is_Hidden_In_SPARK then Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); end if; end if; -- Cases other than Package_Body else Scope.Table (Scope.Last).Sloc := Token_Ptr; 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; P_Aspect_Specifications (Package_Node, Semicolon => False); TF_Semicolon; Pop_Scope_Stack; -- Generic package instantiation or package declaration else if Aspect_Specifications_Present then Aspect_Sloc := Token_Ptr; P_Aspect_Specifications (Dummy_Node, Semicolon => False); end if; Is_Sloc := Token_Ptr; 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; if Aspect_Sloc /= No_Location then Error_Msg ("misplaced aspects for package instantiation", Aspect_Sloc); 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); if Aspect_Sloc /= No_Location and then not Aspect_Specifications_Present then Error_Msg_SC ("\info: aspect specifications belong here"); Move_Aspects (From => Dummy_Node, To => Package_Node); end if; P_Aspect_Specifications (Package_Node); 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 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 if Token = Tok_SPARK_Hide then Private_Part_Is_Hidden_In_SPARK := True; Hidden_Region_Start := Token_Ptr; Scan; -- past HIDE directive else Private_Part_Is_Hidden_In_SPARK := False; end if; Set_Private_Declarations (Specification_Node, P_Basic_Declarative_Items); -- In SPARK, a HIDE directive can be placed at the beginning -- of a private part, thus hiding all declarations in the -- private part from SPARK tool-set. No violation of the -- SPARK restriction should be issued on nodes in a hidden -- part, which is obtained by marking such hidden parts. if Private_Part_Is_Hidden_In_SPARK then Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); end if; -- 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, Empty, Is_Sloc); Move_Aspects (From => Dummy_Node, To => Package_Node); end if; end if; end if; return Package_Node; 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;