| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P A R . C H 7 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2018, 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; |
| Current_Node := 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; |
| Current_Node := 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; |
