blob: 4363a649f14fba1a234e781b330f2174c3df15e8 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- P A R . C H 7 --
-- --
-- B o d y --
-- --
-- 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;